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Introduction: This is the source code for the ExpertFlnder system, 
a mixture of inML/ Javascript and Macintosh Common Lisp. 
Copyright (C) 2000, John Sotos All Rights Reserved- 

There are multiple source code files combined into this single file. 
The borders between the original files are delimited by "®@f ile" • lines . 



©©file $boot 

(def parameter *app -packages* 

•((:name "TOKENIZER" :nic3aiame "TK" :var *tk-package*) 
)) 

(defparameter *app- logical -drive* "C") ; used by PC only 
(defparameter *app- logical -directories* 
»{ 

("source" 

#+mcl "HD2 Da : ayudame " 
#-mcl "pubmedW") 
M ("searches" 

O #+mcl "HD20a! ayudame: searches" 

;S #-mcl "pubmedWsearches") 

3 )) 

(defparameter *app-f iles-to-load* 
m ' ( 

; ; ; Load macros not specific to this application 
' ( " source : xserve -macros " ) 

( " source : lisp-macros " ) 

III ; ; ; Load code not specific to this cipplication 

( "source rplatform") ; platform-specific functions 

Ifl ( "source : servjmcl" ) ; platform- specific sez-ver interface 

f^. code 

J^' ("source: xserve") ; server- interface code. Some app- 

specific defs- 

; ; ; Load code specific to this application 
( " source : analyzer" ) 
( " source : places " ) 

( "source :pickfield") ; mostly defines new classes 

( " source : rules " ) 

( "source :places-f ind") 

( " source : noder " ) 

( "source :cgi-fns ") 
{ " source : masterpick" ) 
{ "source : parse-paper" ) 

; ; ; Load data specific to this application 
( " source : countries " ) 

; ("source: states") loaded by countries file 

; ("source :city_inst") loaded by states file 
)) 

(defparameter *app-post-load-eval* • (initialize-searches) ) 
(defparameter *app-post-load-msg* "Entry point is (tally)") 

#+mcl (proclaim '(optimize (debug 3))) 
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#+mcl (let ( (save-stuf f-p #+production- system nil # -production- system t) ) 
(setf *save-definitions* save-stuf f-p 

♦save -doc- St rings * save - stuff -p 

* save - local - symbols * save - s tuf f -p 

♦record-source -file* save-stuf f-p 

*f asl-save-local-symbols* nil) ) 



i t 9 



1 

1 

;;; Generic boot -up code follows. 



tit 
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tit 



;;; PACKAGES 

; ; ; These are some conveniences I like . 

(rename -package * common-lisp -user » common- lisp -user ; add new nickname 

(adjoin "U" (package -nicknames • common-lisp-user) :test 

#• strings) ) 

(rename -package 'common-lisp 'common-lisp ; add new nickname 

(cons « lisp (package -nicknames ' common-lisp ) ) ) 

(or (find-package "BOOT") (make-package "BOOT" :use ' ("U" "LISP"))) 

;;; Define user's packages 

(defmacro boot: : define -packages (package -spec -symbol) 
{flet ( (def inel (package -spec) 

(let ((name (getf package-spec iname nil)) 

(nickname (getf package-spec :nickname nil) ) 
(var (getf package-spec :var nil)) 

(form nil) ) 
(setq form 

^ (or (find-package ,name) 
(make -package , name 

:use ' ("U" "LISP") 
inicknames • nickname) ) ) ) 

(when var 

(setq form (list ' def parameter var form))) 
(values form) ) ) ) 
(cons 'progn 

(mapcar #' def inel (symbol-value package -spec- symbol) ))) ) 
(boot: : define -packages *app -packages*) 



tit 



; ; ; Universal utilities 

(defun dbp (&:rest args) 

(format t "-%;;;-{ ^S-}" args) 
(values) ) 

• •• — — — _ — _ — — 

1 

; ; ; Pathname f ns 
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(flet ((fullpath (logical -path-string) 

(let* ( (colonpos (or (position #\: logical -path- string :test 



#»char=) 



:from-end t) ) 



equal) ) 
dir) ) ) 

string) ) ) ) 



(error "No colon in logical path string -S" 
logical -path-string) ) ) 
(dotpos (position #\ . logical -path- string :test #'char= 

{dir (subseq logical-path-string 0 colonpos) ) 

(extension (and dotpos 

(subseq logical -path-string (1+ dotpos)))) 
(star-exten (and extension 

(string= extension ".*"))) 
(directory (or' (second (find dir *app- logical -directories* 

:key #' first :test #*string- 

( error "Cannot find logical directory: -S" 

(name (subseq logical -path- string (1+ colonpos) 

(or dotpos (length logical -path- 



) 

#+mcl 
(cond 
(star-exten 

(make -pathname : directory directory marae name :type "*«)) 
(extension 

(make -pathname :directory directory :name name :type extension)) 
(t 

(make-pathname :directory directory :name name))) 
#-mcl 

; (make -pathname : device "C" : directory "pubmed\\searches " :name 

"xyz.html") 

(make -pathname :device *app- logical -drive* 
: directory directory 
:name name 
:type "*")))) 

(defun find- latest -path (logical -paths tring) 

"Loads the latest version of a file. Latest = alphabetically last. 
Argument should be a string. 
Filenames should have form ♦ name . ext ' " 

;; < merge -pathnames > yields "name.*" in MCL, at least, 
(let* ({pathname (fullpath logical -paths tring) ) 

(files (directory (merge -pathnames #. (make -pathname) pathname)))) 
(if files 

(first (sort files # • string-greaterp :key # 'names tring ) ) 
(error "Missing file -S" pathname)))) 

(defun find-path (logical -paths tring) 
(fullpath logical -pathstring) ) ) 

(defun boot : :load-aogical-path-file (logicalpathname &key (printp t) ) 
(let ((path (find- latest -path logicalpathname))) 
(when printp 
(dbp path) ) 
(load path) ) ) 
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; ; ; Load files 

(map nil #• boot :: load- logical -path- file (mapcar #'first *app-f iles-to-load*) ) 
(eval *app-post-load-eval*) 

(format t "-&Done loading. -% -A" *app-post-load-msg*) 

@®file analyzer 

(defstruct author 
name 

allpapers 

f irstauthorpapers 

lastauthorpapers 

(score 0) 

) 

(f let ( (p (papers) 
(if papers 

(subseq (format nil (mapcar 'paper-pmid papers)) 

1) 
«,.))) 

(def method print-object ( (x author) s) 

(format s "<AUTHOR name=«-A' allpapers=~A f irstauthorpapers=-A>" 
(author-name x) 
(p (author -allpapers x) ) 
(p (author-f irstauthorpapers x) ) ) ) ) 

(defstruct paper 
; ; Primary data 
pmid 
title 

authorname s 
lastauthor 

pt ; publication type 

address 

year 

country 

authorcount 

* / 

; ; Derived 

allauthors 
(score 0) 

j-^les ; rules -- for places we deduce from 

address 

leaf places ; places deduced from geographic 

hierarchy 

leafplacenodes 

email 

) 

(defvar * tally*) . 
(defparameter *tallies* nil) 

(defstruct tally 
key 

authordata 
paperdata 

searchparms ; used? 
filename 
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nodes 
topnode 

;; These are pickfields. 

wts 
geo 
srt 
frat 
max 

; ; This is a pseudo-pickf ield 

; ; (is a link parameter, but not a pickf ield) 

(sta 1) 
) 

(defvar *line-buf f er*) 

(defun create-tally (&key name date time utc papers) 

;; This function is called from within a database file, which undergoes a 

Lisp LOAD. 

;; The only way to return a value to the calling fiinction is with a throw, 
(declare (ignore date time utc) ) 
(let {(tally (make-tally 

:key (length * tallies*) 

: f i 1 e name name 
: author data nil 
:paperdata papers) ) ) 
(setf (tally-authordata tally) 

(make -hash- table :test #• equal 

:size (* 2 (reduce #•+ papers :key ft'paper- 

authorcount) ) ) ) 

(throw ' tally-created tally) ) ) 

(defun 1x1 -post (tally) 

(dovec (paper i (tally-paperdata tally)) 

(delist (authomame (paper-authomames paper) ) 

(process -author tally paper authomame)) 
(push paper (author-f irstau thorp apers 

(get-author-rec tally (first (paper-authornames paper))))) 
(push paper (author- las tauthorp apers 

(get-author-rec tally (paper -last author paper))))) 
(map nil #• score-paper (tally-paperdata tally)) 
(map nil #• score -authors (tally-paperdata tally))) 

(defun get-author-rec (tally authomame) 
; ; Returns 

(or (gethash authomame (tally-authordata tally) nil) 
(error "No author with name ~S" authomame))) 

(defun tally-from-tallykey (key) 
"Returns NIL or .a tally object" 

(find key *tallies* :test #•= :key #' tally-key) ) 

(defun tally-new-paper (tally) 
(let ( (paper (make-paper) ) ) 

(vector-push-extend paper (tally-paperdata tally) ) 
(values paper) ) ) 

(defun score -paper (paper) 
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; Important that every paper gets at least one point. 
; otherwise it's possible for a node to exist and have zero points, 
; which could lead to divide-by- zero errors in the score bar. 
(let ({pt (mapcar #»string-upcase (paper-pt paper))) ; just in case 
(bonus 0)) 

(cond ((member "EDITORIAL" pt :test #'string=) 

(incf bonus 25) ) 
((some #• (lambda (pubtype) (search "GUIDELINE" pubtype :test 
#»char=)) pt) 

(incf bonus 30) ) 
( (notany #• (lambda (pubtype) (search "REVIEW" pubtype :test 
#'char=)) pt) 

(incf bonus 1) ) 
((member "REVIEW OF REPORTED CASES" pt :test #'string=) 

(incf bonus 10) ) 
((member "REVIEW^ MULTICASE" pt :test #*string=) 

(incf bonus 10) ) 
((member "REVIEW LITERATURE" pt :test #»string=) 

(incf bonus 8) ) 
((member "REVIEW" pt :test #'string=) 

(incf bonus 5) ) 
(t 

(dbp pt) ) ) 
(setf (paper-score paper) bonus) ) ) 

(defun score-authors (paper) 

(let* ( (authors (paper -allauthors paper) ) 
(n-authors (length authors) ) 
(al (first authors)) 
(an (first (last authors))) 

(delta (+ 1 ; at least one point for every paper 
(paper-score paper) ) ) ) 
(delist (au (paper-allauthors paper) ) 

(incf (author-score au) delta)) 
(incf (author-score al) (case n-authors (1 2) (2 0) (3 1) (4 2) (t 3))) 
(when (>= n-authors 3) 

(incf (author-score an) (case n-authors (3 1) (4 1) (t 

2)))) 

)) 

(defun process -author (tally paper authomame) 
(let* ( (authorhash (tally-authordata tally) ) 

(author-rec (or (gethash authorname authorhash nil) 

(setf (gethash authomame authorhash) 
(make - author 
: name authorname 
rallpapers nil 
:f irstauthorpapers nil) ) ) ) ) 
(push paper ( author -allpapers author-rec) ) 
(push author-rec (paper-allauthors paper) ) 
(values author-rec))) 

(defun author -addresses (author) 
(let ( (addresses nil) ) 

(delist (paper (author-f irstauthorpapers author)) 

(push (paper-address paper) addresses) ) 
(values addresses) ) ) 

(defparameter *pubmed- script* 
(format nil "-&<script>- 
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-%pmurl= ' http : //www. ncbi • nlm. nih . gov/ entrez /query . f cgi?db=P\ibMed&:cmd=Retrieve 
&dopt=Abstract&list_uids= ' ; - 

-%function pm (id) {window.open (pmurl+ id, * Experts •) }- 

--%</script>") ) 

(defun find-search (filename) 

(find-path (format nil "searches : -A" filename))) 

(defun make-outpathname (inpathname) 

(find-path (format nil "searches: -A. txt" (pathname -name inpathname)))) 

(defun read-html-and-emit-lxl (filename inpathname outpathname) 
(with-open-file (infile inpathname zdirection : input) 
(with-open-f ile (outfile outpathname : direction : output 

: if -exists : supersede) 
(format outfile " (create-tally :name :date ~S :time ~S :utc ~S 

: papers (vector" 

filename "mmddyy" "hhmmss" (get-universal-time)) 
(catch 'end-of -file 
(loop 

(find-paper-start infile) 
(parse-paper infile outfile) ) ) 
(format outfile "))")) 
(values) ) ) 

(defun set-paper-locations (tally) 

(dovec (paper i (tally-paperdata tally) ) 
(multiple-value-bind (rules email) 

(locate (paper-address paper) ) 
(setf (paper-email paper) email) 
(setf (paper-leafplaces paper) 

(find-leafplaces nil # • certainrule-place 

(setf (paper-rules paper) rules)))))) 

(f let ( (okp (candidate otherplace) 

(or (eql candidate otherplace) 

(place2-is-or-isin-placel otherplace candidate)))) 
(defun find-leafplaces (leaves place-f rom-place-spec-fn place-specs) 
(dolist (place-spec place -specs) 

(let ((place (funcall place-f rom-place-spec-fn place-spec))) 

(unless (find place place-specs :key place-f rom-place-spec-fn : test- 
not #'okp) 

(pushnew place leaves)))) 
; (when (and (cdr leaves) 

{> (count-if #'institution-p leaves) 1)) 
; (setq leaves (remove-if #' institutionl-is-part-of -institution2 

leaves) ) ) 

(values leaves))) 

(flet ((okp (candidate otherplace) 

(or (eql candidate otherplace) 

(not *{place2-is-or-isin-placel candidate otherplace))))) 
(defun find-leafplaces (leaves place-f rom-place-spec-fn place-specs) 
(dolist (place-spec place-specs) 

(let ((place (funcall place-f rom-place-spec-fn place-spec) ) ) 

(unless (find place place-specs :key place-f rom-place-spec-fn : test- 
not #'okp) 

(pushnew place leaves) ) ) ) 

1 1 
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; ; When one institution is part of another, they can both show up as 
leaf places . 

;; Here, we remove the larger institution. 

(when (and (cdr leaves) 

(> (count-if #'institution-p leaves) 1)) 
(let ( (leaves2 nil) ) 
(dolist (leaf leaves) 

(unless (find leaf leaves :test # ' institution2-is-part-of - 
institution!) 

(push leaf leaves2))) 
(setq leaves leaves2))) 
(values leaves) ) ) 

(defun f ind-leafplaces-for-papers (papers) 
(let ((leaves nil)) 

(dolist (paper papers) 

(setq leaves (find- leaf pi aces leaves 

# * identity 

(paper-leafplaces paper) ) ) 
; (FORMAT T "-%-'%-%*-A-% -S" (paper -address paper) (mapcar # 'place-key 
leaves) ) 
) 

; ; nreverse preserves the order in which the papers were presented 
(values (nreverse leaves)))) 

1 

(defstruct search 

pathname filename name description tallied-p (n-authors "?") (n-papers 
" ? " ) ) 

(defvar *searches*) 
(defparameter * search- descriptions* 
'(("brocc" . "Broccoli") 

("sasSOO" . "Sleep apnea and surgery") 
(«sa" . "Sleep apnea"))) 

(defun initialize-searches () 
(setq *searches* nil) 

(dolist (path (directory (find-path "searches :* .html") ) ) 
(add- search : pathname path) ) ) 

(defun add-search (&)cey pathname filename) 
(assert (and (or pathname filename) 

(not (and pathname filename) ) ) 
nil "Specify either pathname or filename to ADD-SEARCH.") 
(if pathname 

(setq filename (format nil "~A,html" (pathname -name pathname))) 
(setq pathname (first (directory (find-path "searches :* .html") ))) ) 
(let ( (name (pathname -name pathname) ) ) 
(assert (every # ' alphanumericp name) nil 

"Bad search name -S -- only letters and digits allowed." name) 
(push (make -search : pathname pathname 

: filename filename 
tname name 

:description (or (cdr (find name *search-descriptions* 

:key #*car 

:test #' string-equal) ) 
" --none--") ) 
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♦searches*) ) ) 



(defun search-tally (search) 

(find (search-filename search) *tallies* :test #• string-equal :key #'tally- 

f ilename) ) 

(defun search-name-from-tally-f ilename (filename) 

(search-name (find filename *searches* :key #' search-filename :test 
#• string-equal) ) ) 

(defun dearch-load (search) 

(tally (search-filename search) ) 
(setf (search-tallied-p search) t) ) 

(defun search-load-all 0 
(delist (search *searches*) 

(unless (search-tallied-p search) 
(search-load search)))) 

(defun search-unload (search) 
(dbp "SEARCH-UNLOAD IS STUB") 
(setf (search-tallied-p search) nil) ) 

(defun search-unload-all 0 
(tally : erase) 

(delist (search *searches*) 

(setf (search-tallied-p search) nil) ) ) 

(defun tally (filename &key show erase all parse) 

;; Exists only so we can call from command line, without huge re tuim- value . 
(let* {(inpathname (find-search filename)) 

(outpathname (make-outpathname inpathname) ) ) 

(cond 

(show (format t «~{--%~S~}" (directory (find-path "searches :* .html") )) ) 

(erase (setq *tallies* nil) 
' erased) 

(all (delist (path (directory (find-path "searches :* .html") ) ) 
(tally (format nil "-A.html" (pathname -name path))))) 

((find filename *tallies* :key #• tally-filename :test #• string-equal) ) 

(parse (time (read -html -and- emit -1x1 filename inpathname outpathname))) 

(t (tallyl filename outpathname) ) ) ) ) 

(defun tallyl (filename outpath) 
(unless (probe-file outpath) 

(tally filename tparse t) ) 
(let ((tally (catch 'tally-created (time (load outpath) ))) ) 

(time (1x1 -post tally) ) 

(time (set -paper- locations tally) ) 

(time (make -nodes tally) ) 

(time (score-nodes tally) ) 

(pushnew tally *tallies*) 

(values tally) ) ) 

@®file cgi-fns 



Page 9 of 82 



(defun html -image -tag (thread src &key (border nil) (align nil) 

(width nil) (height nil) ) 
( f ormat t thread " < image src=s • im j / -A • " src ) 
(when border 

(formatt thread " border*' -A*" border)) 
(when align 

(foirmatt thread " align-* -A'" align)) 
(when width 

(formatt thread « width=*~A'" width)) 
(when height 

(formatt thread " height=»-A» « height)) 
(princt thread)) 

(defun summary (thread tally) 

(formatt thread «~%<br>-D papers , -%<br>-'D authors . -'%<br>'' 
(length (tally-paperdata tally)) 
(hash- table -count (tally-authordata tally) ) ) ) 



— - --I 

(defun node -aside (stream node) 

(format stream "   -S" (length (node-papers node))) 
(when (node -papers? node) 

(format stream " — S" (+ (length {node-papers node}) 

(length (node -papers? node) ) ) ) ) 
(format stream "p~S" (node-score node)) 
(when (plusp (node -score? node) ) 

(fozTTiat stream " — S" (node -total -score node))) 
(pr inc " s " s t r earn) ) 

/ / / 

1 

(def method node -print -name (node) 

(let* ( (name (place-name (node -place node) ) ) 

(pos (position #\$ name :test #*char=))) 
(if pos 

(format nil «--A (-A) " 

(sxibseq name 0 pos) 

(string-upcase (siibseq name (1+ pos))}) 

name) ) ) 

#1 

(def method node -print -name ( (node authomode) ) 
(author -name (authomode -place node) ) } 

(defmethod node -print -name ( (node papernode) ) 
(paper-title (papernode -place node) ) } 

i# 

/ / / ~ ' ~ 



(defcgifn main () 
(main -html thread) ) 

(def parameter *main- j avascript* 

«*<script>f unction su(ac,ta) { f=document . forms [0] ; 
f .elements [ 'ACT* ] . value a±ac; f. elements C 'TGT* 3 .value=ta; f .submit () ; 
}</script>" 
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) 

(defhtmfn main-html (thread) -.props nil 

(with-new-page (thread :title "Welcome to S.O.T.O.S," 

:head *main- javascript*) 
(with-thread-output (stream thread) 
(cgi- form- start thread * searchaction) 
(cgi- form-hidden thread 
•act 
'tgt 

(format stream "-%<table cellpadding= • 5 ' ><tr>- 
<th>Search Name</th>- 
<th>Description</th>* 
<th>Status</th>- 
<th>Action</th>- 

<th>             </th>- 
<th>Load Mgmt</th></tr") 
(dolist (search *searches*) 

(format stream "~%<tr>-@{<td>-A</td>-}</tr>" 
(search-name search) 
(search-description, search) 

(if (search- tallied-p search) "Loaded" "Not loaded") 
(if (search-tallied-p search) 
(format nil 

"<input type= 'button* value- •View* 

onclick=*su('-S,-S) 

"V" (search-name search) ) 
(format nil 

"<input type=* button' value=*Load + View' 

onclick='su(-'S,-S) 

"LV" (search-name search))) 

1! II 

(if (search-tallied-p search) 
(format nil 

"<input type= ' button ' value =' Unload ' 

onclick='su(«S,-S) 

«U" (search-name search)) 
(format nil 

" < input type= ' button • value= * Load ' 

onclicks 'su( -S^-S) 

«L" (search-name search) ) ) ) ) 
(format stream «"%<tr>-®{<td>-A</td>-}<td>~ 

<p>< input types * button • value = 'Unload all' 
onclicks • su (\ "UA\ " , 0 ) • >- 

<p><input types 'button* values «Load all' 
onclicks 'su(\"LA\«,0) ' >^ 

</tr>« 

n M ft f r ft ff n n n ir j 

(format stream "-'%</table></f orm>" ) ) ) ) 



(defcgifn searchaction (act tgt) 

(assert (member act • ("L« "V« "U" «LV" "LA" "UA") :test #' string-equal) nil 

"Illegal action -S" act) 
(let ((target (or (string-equal act "LA") 
(string-equal act "UA") 

(find tgt *searches* :key #' search-name :test #• string- 
equal) ) ) ) 
(cond 
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( (string-equal 


act 




(search-load target) 

/ma I n — Vif~mT f~ViT'^*J4H^ \ 


{ (string- equal 


act 




(search-view-html thread target)) 




act 


•ITTH\ 

W J 


(main-html thread) ) 


( f fit" T^i no —#»cniaX 


act 




f seaircii-Xoad tairofst) 
(search-view-html thread target) ) 


( (string- equal 


act 




(search-load-all) 
(main-html thread) ) 


( (string-equal 


act 


"UA") 


(search-unload-all) 
(main-html thread) ) ) ) ) 



(defcgifn searchhome (id) 

(searchaction thread :act "V" :tgt id)) 



#1 

(defhtmfn error-page (thread title fmt$ fmt-args) :props nil 
(with-new-page (thread : title (format nil "Error - -A" title)) 
(apply #'formatt-fn thread fmt$ fmt-args))) 

i# 

(defun escape -author-name (name) 

; ; no unescape function is needed, because that is taken care of routinely 
when 

;; arguments are accepted from the web browser, 
(substitute #\+ #\Space name :test #'char=)) 

Sit " 

1 

(defhtmfn dummy -thanks (thread filename) : props nil 
(with-new-page (thread : title "Thanks ! " ) 

(formatt thread "-%-%You submitted: -S-%-%Thank you." filename))) 

(defcgifn say_hello (repetition) :props nil 
(with-new-page (thread : t it le "Thanks ! " ) 
(dotimes (i (reaqL-f rom-string repetition)) 

(formatt thread "-%<br>Hello world!")) 
(formatt thread "-%<p><a href=' javascript :hi story. back () »>Go 
Back</a><p>") 

(cgi-anchor-with-text thread "Show tallies" 'main))) ; show_tallies 

(defun make -dummy- thread () 

(make-thread : session (make -a- session) 

: accumulator- stream (open -text -window) ) ) 



@®file city_inst 

#1 

Invisible cities conclude about the country, not the about the city. 
(Actually, they conclude about whatever the 2step key is.) 
So, it makes no sense to have a rule like: 

:dx-helpx "Athens" -AND- co gr 
Because this rule would have its conclusion in its antecedent. 
So these sorts of things tend to get expressed as: 

:dx-helpx "Athens" -NOT- co us 
This is great, but a problem arises when there is a pair of rules 
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that are the same except for the -NOT- / -AND- : 

:dx-helpx "Athens" -NOT- co us 

:dx-helpx "Athens" -AND- co us 
If the country is not established before the :dx-helpx amies are 
tested, then the out come can depend on which rule is tested 
first! The best approach is to pick the less reliable rule and make 
it :sus-helpx 

:sus-helpx "Athens" -NOT- co us ; usually true 

:dx-helpx "Athens" -AND- co us ; always true 

Note that the above does not apply to cities in the United Kingdom, 
Canada, or Ireland. There, we are trying to make a diagnosis at the 
city and institution level- So it does make sense to say: 
:dx-helpx "Dviblin" -AND- co ie 

l# 

{map nil # 'make-a-city 
•{(co de "Aachen" :dxl : invisible) 

(CO uk "Aberdeen$uk" :dx-helpx "Aberdeen" -AND- co uk :dx-all "Aberdeen 

Scotland") 

(CO et "Addis Ababa" :dx2 : invisible) 
(CO au "Adelaide" :dxl : invisible) 

{st oh "Akron" :dx-helpx "Rootstown" -AND- st oh) 

(st ny "Albany" :dxl) 

(st nm "Albuquerque" :dxl) 

{co jo "Amman" :dxl : invisible) 

(co nl "Amsterdam" :dx-helpx "Amsterdam" -NOT- co us : invisible) 
(CO tr "Ankara" :dxl -.invisible) 
(st mi "Ann Arbor" :dx2) 
(st ga "Atlanta" :dxl) 

(co gr "Athens$gr" :sus-helpx "Athens" -NOT- co us : invisible) 
(st ga "Athens$ga" :dx-helpx "Athens" -AND- st ga) 
(co nz "Auckland" :dxl : invisible) 

(st ga "Augusta$ga" :dx-helpx "Augusta" -AND- st ga) 

(co de "Bad Nauheim" :dx2 : invisible) ; Max Planck 

(co in "Bangalore" :dxl : invisible) 

(st md "Baltimore" :dxl) 

(co th "Bangkok" :dxl : invisible) 

(co es "Barcelona" :dxl : invisible) 

(CO ch "Basel" :dxl : invisible) 

(CO uk "Bath" :dx-helpx "Bath" -AND- co uk) 

(CO il "Beer-Sheva" :dxl : invisible) 

(CO cn "Beijing" :dxl : invisible) 

(co uk "Belfast" :dxl) 

(st ca "Berkeley" :sus "Berkeley" :dx-helpx "Berkeley" -AND- st ca) 
(CO de "Berlin" :dxl : invisible) ; ignore New Hampshire 
(co ch "Bern" :sus "Bern" : invisible) ; just seems like there's more 
(st md "Bethesda" :dxl) 

(st al "Birmingham$al" :dx-helpx "Birmingham" -AND- co us) 
(CO uk "Birmingham$uk" :dx-helpx "Birmingham" -AND- co uk) 
(co it "Bologna" :dxl : invisible) 

(st ma "Boston" ^dxl :dx-helpx "Chestnut Hill" -AND- st ma) ; for BI- 
Deaconness 

(co sk "Bratislava" :dxl : invisible) 
(co au "Brisbane" :dxl : invisible) 
(st ny "Buffalo" :dxl) 

(co ar "Buenos Aires" :dx2 : invisible) 
(co in "Calcutta" :dxl : invisible) 
(st ab "Calgary" :dxl) 

(CO uk " Cambridge $uk" :sus-helpx "Cambridge" -AND- co uk) 
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(st ma "CaTnbridge$ma" :sus-helpx "Cambridge" -AND- co us :dx-helpx 
"Cambridge" -AND- st ma) 
(CO uk "Cardiff" zdxl) 

(st sc "Charleston" :dx-helpx "Charleston" -AND- st sc) 
(st va "Charlottesville" :dxl) 
(co jp "Chiba" :sus "Chiba" : invisible) 
(st il "Chicago" :dxl 
:dx "Evanston" 

:dx-helpx "Maywood" -AND- st il) ; Loyola 



(st 


oh 


"Cincinnati" :dxl) 


(st 


oh 


"Cleveland" :dx-helpx "Cleveland" -AND- st oh) ; Cleveland Clinic 


Fla . 






V w 


de 


"Cologne" :dxl :dx "Koln" : invisible) 


fst 

\ o o 


mo 


"ColumhiaSmo" rdx-heltix "Columbia" -AND- st mo) 


(co 


dk 


"Copenhagen" :dxl : invisible) 


( CO 


i e 


"Cork" -dxl) 


(co 


bd 


"Dacca" : dxl idx "Dhaka" 2 invisible) 


(fit- 






(co 


in 




(st 


CO 




(st 


mi 




(co 


de 


" jj2rescieni?cie :sus uirescLeii imvisi-Dj.e/ 


(co 


ie 




others 






(CO 


uk 


' ljunaee ; ox x } 


(co 


za 


"Durban" :dxl : invisible) 


(co 


de 


"Dusseldoirf " :dxl : invisible) 


(st 


wi 


Eau C-Xaire :a-x-ne±px iiau cxaijre ~i\ihu - co us^ 


(co 


uk 


"EdinDurgn" :ax-ne±px "EdinDurgn" -atulj- co ujc; 


(st 


ab 


" Eamont on " : oxi } 


(st 


ct 




(co 


it 


"Fxorence$it tdx "rxrenze :CLx-ne±px "rxorence -jMUi- co us 


: invisible 




(st 


nc 


"Fort Bragg" :dx-helpx "Fort Bragg" -AND- st nc) 


(st 


wa 


rorc Liewis sax- nexpx i?oxc xiewxs — adijj- su wa; 


(st 


tx 


"Fore Sam Houston" :ax^; 


(co 


de 


Vrranjvuuxut^ue s stjib- nex^Jt fxcixijvxux u — jMvyi t.*-/ uo . xuv j.oxj^xc/ 


(st 


ky 


"Frankfurt$us" :dx-helpx "Frankfurt" -AM)- co us) 


(st 


fl 


"Ft. Lauderdale" :dx2 :dx-adj "Ft Lauderdale" :dx-adj "Fort 


Lauderdale 


") 


(st 


tx 


"Ft. Worth". :dx2 :dx-adj "Ft Worth" :dx-adj "Fort Worth") 


(st 


fl 


"Gainesville" :dxl) 


(st 


tx 


"Galveston" :dxl) 


(co 


it 


"Geneva" :dxl :dx-helpx "Genoa" -NOT- co us : invisible) 


(co 


uk 


"Glasgow" :dxl) 


(co 


de 


"Gottingen" :dxl : invisible) 


(st 


nd 


"Grand Forks" :dx2) 


(st 


nc 


"Greenville$nc" :dx-helpx "Greenville" -AND- st nc) 


(co 


il 


"Haifa" :dxl : invisible) 


(co 


de 


"Hamburg" :dxl : invisible) 


(st 


nh 


" Hanove r / Lebanon$ nh " 



:dx-helpx "Lebanon" -AND- st nh 
:dx-helpx "Hanover" -AND- st nh) 
(co fi "Helsinki" :dxl : invisible) 

(st pa "Hershey$pa" :dx-helpx "Hershey" -AND- st pa) 
(st hi "Honolulu" :dxl) 

(st tx "Houston" :dx-helpx "Houston" -NOT- ci "Fort Sam Houston") 

(co in "Hyderabad" :dxl : invisible) 

(st in "Indianapolis" :dxl) 

(st ia "Iowa City" :dx2) 

;;;;;; Irvine -- see Los Angeles 
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(CO 


tr 


(St 


ny 


(St 


ms 


(St 


fl 


(St 


ma 


(CO 


il 


(St 


mi 


(co 


jp 


(St 


ks 


(co 


sd 


(co 


jp 


(St 


qc 


(co 


uk 


(st 


ky 


(co 


pt 


(St 


ar 


(co 


uk 


(st 


on 


Ontario") 


(co uk 


England") 


(st 


ca 



"Istanbul" :dxl : invisible) 
"Ithaca" :dxl) 

"Jackson" :dx-helpx "Jackson" -AND- st ms) ; Jackson Hospital? 
" Jacksonvi lie" : dxl ) 
"Jamaica Plain" :dx2) 
"Jerusalem" :dxl : invisible) 
"Kalamazoo" :dxl) 

"Kanagawa" :sus "Kanagawa" : invisible) 
"Kansas City" :dx2) 
"Khartoum" :dxl : invisible) 
"Kobe" :dxl : invisible) 

"Laval" :dx-helpx "Laval" -AND- co ca) 
"Leeds" :dxl) 

"Lexington$ky" :dx-helpx "Lexington" -AND- st ky) 
"Lisboa" :dxl :dx-helpx "Lisbon" -NOT- co us : invisible) 
"Little Rock" :dx2) 
"Liverpool" :dxl) 

"London$on" :dx-helpx "London" -AND- co ca :dx-adj "London, 

"London$en" :dx-helpx "London" -AND- co uk :dx-adj "London, 

"Los Angeles" :dx2 
:dx-helpx "Irvine" -AND- st ca) 
(st ky "Louisville" :dxl) 
(st tx "Lubbock" :dxl) 
(co nl "Maastricht" :dxl .-invisible) 
(st wi "Madison" :dxl) 
(co in "Madras" :dxl : invisible) 
(co es "Madrid" :dxl : invisible) 

(co uk "Manchester$uk" :dx-helpx "Manchester" -AND- co uk :dx-adj 
" Manches t er , Engl and " ) 

(co de "Marburg" :sus "Marburg" : invisible) 

(co au "Melbourne" :dx-helpx "Melbourne" -NOT- co us :invisible) ; Florida 
(st tn "Memphis" :dxl) ; ignore Egypt 

(co mx "Mexico City" :dx2 :dx-all "Mexico DF" :dx-all "Mexico D.F." :dx- 
all "Mexico D.F.," : invisible) 

(st fl "Miami" :dx-helpx "Miami" -AND- st fl :dx-adj "Miami Beach") 
(CO uk "Middlesex$uk" :dx-helpx "Middlesex" -AND- co uk) 
(co it "Milan" :dxl :dx "Milano" : invisible) 
(st wi "Milwaukee" :dxl) 

(st ny "Mineola" :dx-helpx "Mineola" -AND- st ny) ; just seems safer 
(st mn "Minneapolis" :dxl :dx-helpx "Hennepin County" -AND- st mn) 
(co fr "Montpellier" :dxl : invisible) 
(st qc "Montreal" :dxl) 

(st wv "Morgantown" :dx-helpx "Morgan town" -AND- st wv) 

(co ru "Moscow" :dx-helpx "Moscow" -NOT- co us : invisible) 

(co de "Munich" :dxl :dx "Munchen" : invisible) 

(co de "Mimster" :dx-helpx "Munster" -NOT- co us : invisible) 

(st tn "Nashville" :dxl) 

(co in "New Delhi" :dx2 : invisible) 

(st ct "New Haven" :dx2) 

(st la "New Orleans" :dx2) 

(st ny "New York City" :sus-adj "New York" :dx-adj "New York, NY" 
:dx-adj "New York, New York" !dx-adj "NY, NY" 
:dx "Brooklyn" :dx "Bronx" :dx-helpx "Harlem" -AND- co us) 

(st nj "Newark$nj" :dx-helpx "Newark" -NOT- st de) 

(co uk "Newcastle upon Tyne" :dx2 :dx-helpx "Newcastle" -AND- co uk) 
(st va "Norfolk$va" :dx-helpx "Norfolk" -AND- co us :dx-helpx "Portsmouth" 
-AND- st va) 

(st ca "Oakland" :dxl) 

(st ok "Oklahoma City" :dx2) 
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(St ne "Omaha" :dxl) 

(co jp "Osaka" :dxl : invisible) 



(co no "Oslo" :dxl 
(co uk "Oxford$en" 
(st oh "OxfordSoh" 



: invisible) 

:dx-helpx "Oxford" -AND- co uk) 
:dx-helpx "Oxford" -AND- st oh) 
(co it "Padua" :dxl : invisible) 

(st ca "Palo Alto" :dx2 :dx-helpx "Stanford" -AND- st ca) 
(co fr "Paris" :dxl : invisible) 
(co au "Perth" :dxl : invisible) 
(st pa "Philadelphia" :dxl) 

(st az "Phoenix" :dxl :dx-helpx "Scottsdale" -AND- st az) 
(st pa "Pittsburgh" :dxl) ; ignore calif. 
;; Portsmouth, VA -- see Norfolk 
(co cz "Prague" :dxl : invisible) 
(st nj "Princeton" :dxl) 

(st ri "Providence" :dx-helpx "Providence" -AND- st ri) ; Sisters of 
Providence 

(st nc "Research Triangle" :dx2 

:dx-adj "Chapel Hill" 

:dx-helpx "Raleigh" -AND- st nc 

:dx-helpx "Durham" -AND- st nc 

:dx-all "Duke Durham") 
(st va "Richmond" :dxl :dx~helpx "Richmond" -AND- co us) 

(st mn "Rochester$ran" :dx-helpx "Rochester" -AND- st mn :dx-all "Rochester 
MN" :dx-all "Rochester Minnesota") 

(st ny " Roches ter$ny" :dx-helpx "Rochester" -AND- st ny :dx-all "Rochester 
NY" :dx-all "Rochester New York") 

(st ny "Rome$ny" :dx-helpx "Rome" -AND- st ny :dx-all "Rome NY") 

(co it "Rome$it" :dx-helpx "Rome" -NOT- co us :dx "Roma" : invisible) 

(co nl "Rotterdam" :dxl : invisible) 

(st ca "Sacramento" :dxl 

:dx-helpx "Davis" -AND- st ca) 

(st ut "Salt Lake City" :dx2) 

(st tx "San Antonio" :dx2) 

(st ca "San Diego" :dx2 :dx-adj "La Jolla") 
(st ca "San Francisco" :dx2) 

(st ca "San Jose" :dx-helpx "San Jose" -AND- co us) 
(co br "Sao Paulo" :dx2 : invisible) 
(co jp "Sapporo" :dxl : invisible) 
(st .sk "Saskatoon" :dxl) 

(st ny "Schenectady" :dxl) ; General Electric Corporate Research 

(st wa "Seattle" :dxl) 

(co jp "Sendai" :dxl : invisible) 

(st la "Shreveport" :dxl) 

(co uk «Southampton$uk" :dx-helpx "Southampton" -AND- co uk) 
(st mo "St. Louis" :dx2 :dx-adj "St Louis") ; French hospitals? 
(co se "Stockholm" :dxl : invisible) 

(st ny "Stony Brook$ny" :dx-helpx "Stony Brook" -AND- st ny :dx-all "Stony 
Brook NY") 



(co uk "Surrey" 
(co au "Sydney" 
(CO tw "Taipei" 



:dxl) 

:dx-helpx "Sydney" -NOT- co us : invisible) 
:dxl : invisible) 
(st fl "Tampa" - :dxl) 

(co ge "Tbilisi" :dxl :dx-all "T'bilisi" ; invisible) 

(co il "Tel Aviv" :dx2 :dx "Tel-Aviv" : invisible) 

(co il "Tel Hashomer" :dx2 : invisible) 

(co jp "Tokyo" :dxl :dx "Tokio" : invisible) 

(st oh "Toledo" :dx-helpx "Toledo" -AND- co us) ; Spain 

(st on "Toronto" :dxl) 

(st az "Tucson" :dxl) 

(co de "Ulm" :dx-all "Ulm Germany" : invisible) 
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(st pa "University Park$pa" sdx-helpx "University Park" -AND- st pa) ; 
Penn State 

(st il "Urbana" :dxl) 
(st be "Vancouver" :dxl) 

(co pi "Warsaw" :dx-helpx "Warsaw" -NOT- co us : invisible) 
(st dc "Washington$dc" :dx-helpx "Washington" -AND- st dc :dx-all 
"Washington DC") 

(st vt "White River Junction" :dx2) 

(st de "Wilmington$de" :dx-helpx "Wilmington" -AND- st de :dx-all 
"Wilmington Del.") 

(st nc "Wilmington$nc" :dx-helpx "Wilmington" -AND- st no) 
(st mb "Winnipeg" :dxl) 

(st nc "Winston-Salem" :dx-adj "Winston-Salem" :dx-adj "Winston Salem") 

(co jp "Yonago" :dxl : invisible) 

(co uk "York$uk" :dx-helpx "York" -AND- co lik) 

(co ch "Zurich" :dxl : invisible) 

)) 



(map nil # 'make -an- institution 
' ( 

("Albany Medical College" ci "Albany" 
:dx2 

:dx-adj "Albany Medical Center" 

: edu - domain " amc " ) 
("Albert Einstein School of Medicine" ci "New York City" 
:dx2 

:dx-adj "Albert Einstein College of Medicine" 

:dx-all "Albert Einstein Yeshiva" 

sdx-all "Albert Einstein New York" 

: domain "aecom.yu.edu") 
("Albert Einstein Medical Center" ci "Philadelphia" 

:dx-helpx "Albert Einstein" -AND- ci "Philadelphia") 
("Alfred I, duPont Institute" ci "Wilraington$de" 

:dx-all "Alfred I duPont Institute") 
("American Heart Association" ci "Dallas" 

:dx2) 

("Baylor College of Medicine" ci "Houston" 
:dx-adj "Texas Children's Hospital" 
:dx2) 

("Beth Israel Deaconess Medical Center" ci "Boston" 
:dx2) 

("Boston University" ci "Boston" 
:dx2 

:dx-adj "Boston City Hospital") 
("Brown University" ci "Providence" 
:dx2 

:dx-adj "Rhode Island Hospital") 
("Case Western Reserve University" ci "Cleveland" 
:dx2 

:dx-helpx "Case Western" -AND- st oh) 
("Centers for Disease Control" ci "Atlanta" 
:dx2 

:dx-helpx "CDC" -AND- ci "Atlanta" 
: doma in " cdc . gov " ) 
("Children's National Medical Center" ci "Washington$dc" 
:dx2) 

("Cleveland Clinic" ci "Cleveland" 

:dx-helpx "Cleveland Clinic" -AND- st oh) 
("Cleveland Clinic Ft, Lauderdale" ci "Ft. Lauderdale" 
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:dx-helpx "Cleveland Clinic" -AND- st fl 
idx-all "Cleveland Clinic Florida" 
:dx-all "Cleveland Clinic Lauderdale") 
("Columbia University" ci "New York City" 
:dx "Columbia-Presbyterian" 
:dx2 

:dx-helpx "Columbia" -AND- st ny 
:dx-all "Columbia Physicians Surgeons" 

:dx-helpx "College of Physicians and Surgeons" -AND- co US 

:edu-domain "Columbia") 
("Cornell University" ci "Ithaca" 

:dx-helpx "Cornell" -AND- ci "Ithaca" 

: edu- domain " Cornell " ) 
("Creighton University" ci "Omaha" 

:dx2) 

("Dartmouth College" ci "Hanover/Lebanon$nh" 
:dx2) 

("Dartmouth Medical School" ci "Hanover/Iiebanon$nh" 
:dx2 

:dx-all "White River Junction VA" 
:dx-all "White River Junction Veterans" 
:ispartof "Dartmouth College") 
("Duke University" ci "Research Triangle" 
:dx2) 

("East Carolina University" ci "Greenville $nc" 
:dx2) 

("Eastern Virginia Medical School" ci "Norfolk$va" 
:dx2) 

("Emory University" ci "Atlanta" 
:dx2 

:edu-domain "emory") 
("George Washington University" ci "Washington$dc" 
:dx2 

:dx-adj "George Washington Univ" 
:dx-adj "Geo. Washington University" 
;dx-adj "Geo Washington University" 
:dx-adj "Geo. Washington Univ") 
("Georgia State University" ci "Atlanta" 
:dx2) 

("Harvard University" ci "Boston" 
:dx "Harvard" 

sdx-adj "Massachusetts General" 
:dx-adj "Channing Laboratory" 
*:dx-adj "Brigham and Women's Hospital" 
:dx-helpx "Children's Hospital" -AND- ci "Boston" 
:dx-helpx "Dana Farber" -AND- st ma 
:dx-all "Dana Farber Cancer" 

:dx-adj "Massachusetts Eye and Ear Infirmary" 
:dx-helpx "Eye and Ear Infirmary" -AND- st ma 
:edu-domain "harvard") 
("Henry Ford Hospital" ci "Detroit" 
:dx2 

: WWW "http : // www . henryf ordhealth . org " ) 
("Indiana University School of Medicine" ci "Indianapolis" ; 



cf . Indiana 



:dx2) 

("Johns Hopkins University" ci 
:dx-adj "Johns Hopkins" 
:dx-helpx "John Hopkins" -AND- 
:edu -domain "jhmi" 
:edu-domain "jhu") 



"Baltimore* 



ci "Baltimore" 
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("Louisiana State University" ci "Shreveport" 

:dx-adj "Louisiana State University Health" 

:dx-adj "Louisiana State University Medical" 

:dx-all "Lousiana State Shreveport" 

:edu-domain "Isu") 
("Lovelace Medical Center" ci "Albuquercpie" 

:dx2) 

("Loyola University Stritch School of Medicine" ci "Chicago" 

:dx-helpx "Loyola" -AND- St il 

:dx-adj "Stritch School of Medicine" 

:zip "60153" 

:edu- domain "luc") 
("Madigan Army Medical Center" ci "Fort Lewis" 

:dx2) 

("Mayo Clinic Jacksonville" ci "Jacksonville" 

:dx-all "Mayo Clinic Jacksonville" 

:dx-helpx "Mayo" -AND- st fl) 
("Mayo Clinic Rochester" ci "Rochester$mn" 

:dx-all "Mayo Clinic Rochester" 

:dx-helpx "Mayo" -AND- st ran) 
("Mayo Clinic Scottsdale" ci "Phoenix" 

:dx-all "Mayo Clinic Scottsdale" 

:dx-helpx "Mayo" -AND- st az) 

("Medical College of Georgia" ci "AugustaSga" 
:dx2) 

("Medical College of Ohio" ci "Toledo" 
:dx2) 

("Medical College of Pennsylvania" ci "Philadelphia" 
:dx2 

:dx-helpx "MCP" -AND- ci "Philadelphia") 
("Medical College of Virginia" ci "Richmond" 
:dx2 

:dx-helpx "MCV" -AND- ci "Richmond" 
:ispartof "Virginia Commonwealth University") 
("Medical College of Wisconsin" ci "Milwaukee" 
:dx2 

:dx-helpx "MCW" -AND- ci "Milwaukee") 

("Medical University of South Carolina" ci "Charleston" 
:dx2 

:zip "29425" 
:edu-domain "muse") 
("Mercy Hospital of Pittsburgh" ci "Pittsburgh" 
;dx2 

:ispartof "Thomas Jefferson University" 
: domain "raer cy 1 ink , org " ) 
("Miami Children's Hospital" ci "Miami" 
:dx2) 

("Miami University" ci "Oxford$oh" 

:dx-helpx "Miami University" -AND- st oh) 
("Montefiore Medical Center" ci "New York City" ; Bronx 

:zip "10467" 

:dx2) 

("Mount Sinai School of Medicine" ci "New York City" 
:dx2 

:dx-all "Mt Sinai School of Medicine" 
:dx-helpx "Mount Sinai Medical Center" -AND- st ny 
:dx-helpx "Mt Sinai Medical Center" -AND- st ny 
sdx-helpx "Mt. Sinai Medical Center" -AND- st ny) 
("New England Medical Center" ci "Boston" 
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:dx2) 

("National Institutes of Health" ci "Bethesda" 
:dx2 

:dx-helpx "NIH" -AND- ci "Bethesda" 
:dx-adj "National Cancer Institute" 
:dx-all "National Heart Lung Blood Institute" 

:dx-all "National Institute of Neurological Disorders and Stroke" 
:dx-all "National Institute on Aging" ; Baltimore!! 
:*dx-adj "National Institutes of Mental Health" 
:dx "NHIiBI" 
:dx "NIDDK" 
:dx "NIMH" 
:dx "NINDS" - 
2 domain "nih.gov") 
("Naval Medical Center Portsmouth" ci "Norfolk$va" 
:dx2 

:dx~helpx "Naval Medical Center Portsmouth" -AND- co us) 
("New York University" ci "New York City" 
:dx2 

: edu - domain " nyu " 

:zip "10016") 
("Northeastern University" ci "Boston" 

:dx-helpx "Northeastern University" -AND- ci "Boston") 
("Northeastern Ohio Universities College of Medicine" ci "Akron" 

:dx2 

: edu -domain "neoucom" ) 
("Northwestern University" ci "Chicago" 
:2ip "60611" 
:dx2 

: edu - doma in " nwu " ) 
("Pennsylvania State University" ci "University Park$pa" 

:dx-helpx "Pennsylvania State University" -NOT- in "Pennsylvania State 
University College of Medicine") 

("Pennsylvania State University College of Medicine" ci "Hershey$pa" 

:dx2 

:dx-all "Penn State University College of Medicine" 

:dx-all "Penn State Hershey" 

:dx-all "Pennsylvania State Hershey" 

:dx-adj "Hershey Medical Center") 
("Pharmacia and Upjohn" ci "Kalamazoo" 

:dx-all "Pharmacia Upjohn" 

: doma in "pnu . com " > 
("Rockefeller University" ci •'New York City" 

:dx2) 

("Rush Presbyterian St. Luke's" ci "Chicago" 
:dx-adj "Rush Presbyterian St" 
:dx-adj "Rush-Presbyterian-St " 
:dx-adj "Rush Presbyterian St»" 
: dx-adj "Rush-Presbyterian-St . " 
:dx-adj "Rush Presbyterian Saint" 
: dx-adj "Rush-Presbyterian-Saint " 

:dx-helpx "Rush Presbyterian" -AND- ci "Chicago" 
:dx-helpx "Rush-Presbyterian" -AND- ci "Chicago" 
:dx-adj "Rush Children's Hospital" 
: dx-adj "Rush Medical College") 
("Rutgers University" ci "Newark$nj " 
:dx2 

: dx-adj "New Jersey Medical School" 

:dx-all "University Medicine Dentistry New Jersey" 

:dx-helpx "UMDNJ" -AND- co us 

: dx-adj "Robert Wood Johnson Medical School") 
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("Saint Louis University" ci "St* Louis" 
:dx2) 

("Scottish Rite Children's Medical Center" ci "Atlanta" 
:dx2 

:dx-helpx "Scottish Rite Children's" -AND- ci "Atlanta" 
: domain " choa . org " ) 
("Stanford University" ci "Palo Alto" 
:dx2 

:www "http; //www. stanford.edu" 

: edu-domain "Stanford " ) 
("SUNY Brooklyn" ci "New York City" 

:dx-all "State University New York Brooklyn" 

:dx-all "Health Science Center Brooklyn" 

: edu-domain "hscbklyn" ) 
("SUNY Buffalo" ci "Buffalo" 

:dx-all "State University New York Buffalo") 
("SUNY Stony Brook" ci "Stony Brook$ny" 

:dx-all "SUNY Stony Brook" 

:dx-all "State University New York Stony Brook" 
: edu-domain "sunysb") 
("Temple University" ci "Philadelphia" 
:dx2) 

("Texas Tech University" ci "Lubbock" 
:dx2) 

("Thomas Jefferson University" ci "Philadelphia" 
:dx2 

:dx-adj "Jefferson Medical College") 
("Tufts University" ci "Boston" 
:dx2 

:dx-helpx "Tufts" -AND- ci "Boston" 
: edu-domain "tufts") 
("Tulane University" ci "New Orleans" 
:dx2 

:dx-adj "Tulane Hospital for Children" 

:dx-helpx "Tulane" -AND- st la ; no other campuses I hope 
: edu-domain "tulane") 
("Uniformed Services University" ci "Bethesda" 
:dx2 

: domain "usuhs.mil") 

("University of Alabama" ci "Birmingham$al" 
:dx2) 

("University of Arizona" ci "Tucson" 
:dx2 

:edu-domain "arizona") 
("University of Arkansas" ci "Little Rock" 
:dx2) 

("University of California Berkeley" ci "Berkeley" 

:dx-all "University of California Berkeley" 

: edu-domain "berkeley") 
("University of California Davis" ci "Sacramento" 

:dx-all "University of California Davis") 
("University of California Irvine" ci "Los Angeles" ; Irvine is in LA+/- 

:dx-all "University of California Irvine") 
("University of California Los Angeles" ci "Los Angeles" 

:dx-adj "University of California, Los Angeles" ; U. of So. Cal., LA if 
dx-all 

:dx "UCLA" 

:dx "Harbor -UCLA" 

: edu-domain "ucla") 
("University of California San Diego" ci "San Diego" 
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:dx-all "University of California San Diego" 
:dx "UCSD" 
:edu-domain "ucsd") 
("University of California San Francisco" ci "San Francisco" 
:dx "UCSF" 

:dx-all "University of California San Francisco" 
:dx-adj "California Pacific Medical Center" 
:edu-domain "ucsf") 
("University of Chicago" ci "Chicago" 
:dx2 

:zip "60637") 
("University of Cincinnati" ci "Cincinnati" 
:dx2 

:edu -domain "uc") 
("University of Colorado Health Sciences Center" ci "Denver" 
:dx2 

:dx-helpx "University of Colorado" -AJID- ci "Denver" 
:dx~helpx "National Jewish" -AND- ci "Denver" 
:dx-adj "National Jewish Medical and Research Center" 
: domain "njc.org") 
("University of Connecticut" ci "FarmingtonSct" 
:dx2) 

("University of Florida" ci "Gainesville" ; cf U. South Florida 
:dx2} 

("University of Hawaii" ci "Honolulu" 
:dx2) 

("University of Illinois Chicago" ci "Chicago" 

:dx-all "University of Illinois Chicago") 
("University of Iowa" ci "Iowa City" 

:dx2) 

("University of Kansas" ci "Kansas City" 
:dx2) 

("University of Kentucky" ci "Iiexington$ky" 
:dx2) 

("University of Louisville" ci "Louisville" 
:dx2) 

("University of Maryland" ci "Baltimore" 
:dx2) 

("University of Miami" ci "Miami" 
:dx2 

:sus-helpx "Miami University" -AND- st fl 
:dx-helpx "Jackson Memorial" -AND- ci "Miami" 
:dx-adj "Bascom Palmer" 
:edu- domain "miami") 
("University of Michigan" ci "Ann Arbor" 
:dx2) 

("University of Minnesota" ci "Minneapolis" 
:dx2 

:dx-adj "Hennepin County Medical Center" 

:zip "55455" 
: edu - doma in " uran " ) 
("University of Mississippi" ci "Jackson" 
:dx2 

:dx-helpx "UMC" -AND- ci "Jackson") 
("University of Missouri" ci "Columbia$mo" 
:dx2) 

("University of Nebraska" ci "Omaha" 
:dx2) 

("University of New Mexico" ci "Albucjuerque" 
:dx2) 

("University of North Carolina" ci "Research Triangle" 
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:dx2) 

("University of North Dakota" ci "Grand Forks" 
:dx2} 

("University of Oklahoma" ci "Oklahoma City" 
:dx2) 

("University of Pennsylvania" ci "Philadelphia" 
:dx2 

:dx-adj "Children's Hospital of Philadelphia" 
:dx-all "Fox Chase Cancer" 

:dx-helpx "Fox Chase" -AND- ci "Philadelphia" 
: edu - doma in " chop " ) 
("University of Pittsburgh" ci "Pittsburgh" 
:dx2 

:dx-adj "Children's Hospital of Pittsburgh" 
:edu-domain "pitt") 
("University of Rochester" ci " Roches ter$ny" 
:dx2 

:dx-adj "Strong Memorial Hospital") 
("University of South Florida" ci "Tampa" 
:dx2) 

("University of Southern California" ci "Los Angeles" 
:dx2 

:dx-helpx "Children's Hospital" -AND- ci "IjOS Angeles" 
:edu-domain "use") 
("University of Tennessee" ci "Memphis" 
:dx2 

:dx-all "St Jude Children's Research Hospital Memphis") 
("University of Texas Houston" ci "Houston" 
:dx2 

:dx-helpx "University of Texas" -AND- ci "Houston" 
:dx-helpx "M.D. Anderson" -AND- ci "Houston" 
:dx-all "M.D. Anderson Cancer Center" 
:dx-all "St Luke's Episcopal Hospital" 

:dx-all "St. Luke's Episcopal Hospital" rdomain "sleh.com" 
:edu-domain "tmc") 
("University of Texas Medical Branch" ci "Galveston" 
:dx2 

: edu -domain "utmb" 
:zip "77550") 

("University of Texas San Antonio" ci "San Antonio" 

:dx-all "University of Texas San Antonio") 
("University of Texas Southwestern" ci "Dallas" 

:dx2 

:dx-all "University of Texas Southwestern" 
:dx-helpx "University of Texas" -AND- ci "Dallas" 
:dx-all "Parkland Hospital" 
:zip "75235") 
("University of Utah" ci "Salt Lake City" 
:dx2 

:edu-domain "Utah") 
("University of Virginia" ci "Charlottesville" 
:dx2) 

("University of Washington" ci "Seattle" 
:dx2 

:dx-adj "Harborview Medical Center" 
:dx-all "Fred Hutchinson Cancer") 
("University of Wisconsin" ci "Madison" 
:dx2 

:dx-adj "University of Wisconsin-Madison" 
; edu -doma in "wise") 
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("Vanderbilt University" ci "Nashville" 

:dx "Vanderbilt") 
("Virginia Commonwealth University" ci "Richmond" 

:dx2) 

("Virginia Mason Medical Center" ci "Seattle" 
:dx2 

:www "http://www.vmmc.org" 
:zip "98111") 
("Wake Forest University" ci "Winston-Salem" 
:dx2 

:dx-helpx "Bowman Gray" -AND- st nc 
:edu- domain "wfu" 
:zip "27157") 

("Walter Reed Army Medical Center" ci "Washington$dc" 

:dx-adj "Walter Reed") 
("Washington University" ci "St. Louis" 

:dx-helpx "Washington University" -AND- st mo ; Geo. Wash. U. 

:zip "63110" 

:edu-domain "wustl") 
("Wayne State University" ci "Detroit" 

:dx2 

:dx-adj "Harper Hospital") 
("Weill Medical College" ci "New York City" 
:dx2 

:dx-adj "Cornell University Medical College" ; old name 
:dx-adj "Weil Medical College" ; common mis-spelling 
:www "http://www.med.comell.edu" 
: domain "med . Cornell . edu" 
:ispartof "Cornell University") 
("West Virginia University" ci "Morgantown" 
:dx2) 

("Winthrop University Hospital" ci "Mineola" 
:dx2 

: domain " winthrop . org " ) 
("Yale University" ci "New Haven" 
:dx "Yale" 
:edu-domain "yale") 

;; *** Canada *** 

("McGill University" ci "Montreal" 
:dx2 

:dx-adj "Montreal General Hospital" 

5 domain "mcgill . ca" ) 
("Universite of Laval" ci "Laval" 

:dx~helpx "Universite Laval" -AND- co ca 

: domain "ulaval . ca" ) 
("University of Alberta" ci "Edmonton" 

:dx2) 

("University of British Columbia" ci "Vancouver" 
:dx2 

: domain "ubc.ca") 
("University of Calgary" ci "Calgary" 
:dx2 

:dx-helpx "Alberta Children's Hospital" -AND- co ca 
: domain "ucalgary.ca") 
("University of Manitoba" ci "Winnipeg" 
:dx2 

:dx-helpx "St Boniface General Hospital" -AND- co ca 
:dx-helpx "St* Boniface General Hospital" -AND- co ca 
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: domain "umanitoba. ca") 
("University of Montreal" ci "Montreal" 
:dx2 

:dx-helpx "Cartierville Hospital" -AND- st qc 
:dx-adj "Universite de Montreal") 
("University of Saskatchewan" ci "Saskatoon" 

:dx2) 

("University of Toronto" ci "Toronto" 
:dx2 

:dx-helpx "Hospital for Sick Children" -AND- ci "Toronto" 
: domain "utoronto . ca " ) 
("University of Western Ontario" ci "London$on" 
:dx2 

: doma in " uwo . ca " ) 

. • ********************** 
*** United Kingdom *** 
; ; See : http : //www . londonmedicine . org • uk/medlist . htm 

("Charing Cross and Westminster Medical School" ci "London$en" 
:dx2 

:dx-all "Charing Cross London" 

:ispartof "Imperial College School of Medicine") 
("Eastman Dental Institute and Hospital" ci "London$en" 
:dx2 

: domain "eastman.ucl.ac.uk" 

: www "http : / /www . eastman . ucl . ac . uk" 

:ispartof "UCL Medical School") 
("Great Ormond Steet Hospital for Children" ci "London$en" 

:dx-adj "Great Ormond Street Hospital" 

lispartof "Institute of Child Health") 
("GKT School of Medicine" ci "London$en" 

:dx-all "Guy's King's St Thomas' School of Medicine" 

:dx-adj "United Medical and Dental Schools" 

:www "http: //www. kcl .ac.uk/depsta/medicine/index.html") 
("Guy's Hospital" ci "Iiondon$en" 

:dx2 

:ispartof "GKT School of Medicine") 

("Imperial College School of Medicine" ci "Iiondon$en" 
:dx2 

:sus-adj "Imperial College" 
:www "http://www.med.ic.ac.uk" 
:domain "med.ic.ac.uk") 
("Imperial College School of Medicine at the National Heart and Lung 
Institute" ci "London$en" 
:dx2 

:dx-helpx "National Heart and Lung Institute" -AND- co uk 
:ispartof "Imperial College School of Medicine") 
("Imperial College School of Medicine at St. Mary's" ci "London$en" 
:dx2 

:dx-helpx "St Mary's" -AND- ci "London$en" 
:dx-helpx "St* Mary's" -AND- ci "London$en" 
:ispartof "Imperial College School of Medicine") 

("Institute of Cancer Research" ci "Surrey" 

:dx-helpx "Institute of Cancer Research" -T^ND- co uk 

:www "http://www.icr.ac.uk") 
("Institute of Child Health" ci "London$en" 

:dx-helpx "Institute of Child Health" -AND- co uk 

idomain "ich.ucl.ac.uk" 
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:www "http://www.ich, ucl.ac.uk" 

:ispartof "UCL Medical School") 
("Institute of Neurology" ci "London$en" 

:dx-helpx "Institute of Neurology" -AND- co uk 

:dx-all "Neurology Queen Square" 

: domain "ion.ucl , ac .uk" 

:www "http://www.ion.ucl.ac.uk" 

:ispartof "UCL Medical School") 
("Institute of Ophthalmology" ci "London$en" 

:dx-helpx "Institute of Ophthalmology" -AND- co uk 

:www "http://www.ucl.ac.uk/ioo/" 

:ispartof "UCL Medical School") 
("Institute of Orthopaedics" ci "Middlesex$uk" 

:dx-helpx "Institute of Orthopaedics" -AND- co uk 

rispartof "UCL Medical School") 
("Institute of Psychiatry" ci "London$en" 

:dx-helpx "Institute of Psychiatry" -AND- co uk 

:www "http://www.iop.bpmf.ac.uk") 
("Institute of Urology and Nephrology" ci "London$en" 

:dx-helpx "Institute of Urology" -AND- co uk 

:dx-helpx "Institute of Nephrology" -AND- co uk 

:ispartof "UCL Medical School") 

("King's College School of Medicine and Dentistry" ci "London$en" 
:dx2 

tispartof "GKT School of Medicine") 
("Middlesex Hospital" ci "London$en" 

:dx-helpx "Middlesex Hospital" -AND- co uk 

rispartof "UCL Medical School") 
("Leeds General Infirmary" ci "Leeds" 

:dx2) 

("London School of Hygiene and Tropical Medicine" ci "London$en" 
:dx2 

: domain "lshtm.ac.uk" 

:ispartof "University of London") 
("Royal Brompton Hospital and/ or Trust" ci "London$en" 

:dx-adj "Royal Bron^ton") 
("Royal Free and University College Medical School" ci "LondonSen" 

:dx-all "Royal Free London" 

:dx-helpx "Royal Free" -AND- co uk 

: domain "rfhsm.ac.uk" 

: domain "rfc.ucl.ac.uk" 

:www "http://www.rfhsm.ac.uk" 

:ispartof "UCL Medical School") 
("Royal Postgraduate Medical School" ci "London$en" 

:dx2 

:ispartof "Imperial College School of Medicine") 
("School of Pharmacy" ci "London$en" 

:dx-helpx "School of Pharmacy" -AND- ci "London$en" 

:www "http://www.ulsop.ac.uk" 

: domain "ulsop.ac.uk" 

:ispartof "University of London") 
("St. Bartholomew's and the Royal London Hospital School of Medicine and 
Dentistry" ci "London$en" 

:dx-helpx "St Bartholomew's" -AND- co uk 

:dx-helpx "St. Bartholomew's" -AND- co uk 

:dx-adj "Royal London School of Medicine" 

:www "http://www.mds.qmw.ac.uk/" 

lispartof "University of London") 
("St. George's Hospital Medical School" ci "London$en" 

:dx-all "St George's Hospital Medical School" 
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:dx-helpx "St George's" -AND- co uk 
:dx-helpx "St. George's" -AND- co uk 
: domain " sghms .ac.uk " 
:www "http://www.sghms.ac.uk" 
:ispartof "University of London") 
("St. Thomas' Hospital" ci "Iiondon$en" 
:dx2 

:dx-adj "St Thomas' Hospital" 
:ispartof "GKT School of Medicine") 
("UCL Medical School" ci "London$en" 
:dx2 

:dx-adj "UCL School of Medicine" 
:ispartof "University College London") 
("University College London" ci "London$en" 
:dx2 

: domain "ucl.ac.uk") 
; ; ; university of EAST LONDON 
; ; ; university of GREENWICH 
; ; ; university of HERTFORDSHIRE 

;;; ("University of North London" ci "London$en" 

; ; ; : dx2 

; ; ; : domain "unl . ac . uk" 

;;; :www "http : //www. unl , ac . uk" ) 

("University of Edinburgh" ci "Ediiiburgh" 
:dx2 

:dx-all "Royal Infirmary Edinburgh" 
:dx-all "Edinburgh Royal Infirmary") 
("University of London" ci "London$€n" 
:dx2 

: domain "lon.ac.uk" 
:www "http://www.lon.ac.uk") 
("University of Manchester" ci "Manchester$uk" 
:dx2) 

("University of Oxford" ci "Oxford$en" 
:dx-adj "Oxford University" 
:dx-adj "John Radcliffe Hospital" 
:dx-adj "Oxford Radcliffe Hospital" 
:dx-helpx "Radcliffe" -AND- ci "Oxford$uk" 
:dx-helpx "Osier Chest Unit" -AND- co uk 
:dx-helpx "Churchill Hospital Oxford" -AND- co uk 
:dx2 

: domain "ox.ac.uk") 
("University of Southampton" ci "SouthamptonSuk" 
:dx2 

:dx-adj "Southampton University" 
:dx-adj "Southampton General Hospital" 
: domain "soton.ac.uk") 
("University of Westminster" ci "London$en" 
:dx2 

: domain "wmin.ac.uk" 
:www "http://www.wmin.ac.uk") 
("University of York" ci "York$uk" 
:dx2) 

)) 

. . it************************ 
;; *** Invisible Foreign *** 

(map nil # 'make-an-invisible-institution 
' ( 
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(CO lb :dx-adj "American University of Beirut") ; has NYC P.O. address!!!! 

(co il :dx-adj "Hadassah University") 

(co se :dx-adj "Karolinska Institute" :dx-adj "Karolinska Hospital") 

(co il :dx "Technion") 

(co be :dx-adj "Universite Catholique de Louvain" :dx "Louvain") 

(co jo :dx-adj "University of Jordan") 

)) 



•done 



©Ofile countries 



(prepare -to- load-places ) 
( prepare - to - load - rul e s ) 



( make - a -plane t ) 

(map nil # 'make -a- country 

; ; TLDs from : http : //www . norid . no/domreg . html 
• { 

(us "USA" :tld gov rtld edu :tld mil :dx-adj "USA." 

:place-var *place-usa*) 

(uk "United Kingdom" :dx2 :dx~adj "Great Britain" :dx-adj "UK." :tld gb 
:sus "England" :dx-helpx "Staffordshire" -AND- co uk 
:dx "Scotland" 
:dx-adj "Northern Ireland" 

:dx~helpx "Wales" -NOT- 2 (co au co hk co cn) ; New South Wales; 
Prince of Wales Hosp. in Hong Kong 
:dx "Guernsey" :tld gg 
:dx-adj "Isle of Man" :tld im 
:sus-helpx "Jersey" -NOT- st nj :tld je 
: place -var *place-uk*) 



(ar 
(au 
(at 
(bd 
(be 
(bo 
(br 
(bg 
(ca 
(cl 
(cn 



"Argentina " 

"Australia" 

"Austria" 

"Bangladesh" 

"Belgium" 

V Bolivia" 

"Brazil" 

"Bulgaria" 

"Canada" 

"Chile" 

"China" 



dx-adj "New South Wales" :dx "Queensland") 



Repiiblic of China" 



dxl) 
dxl 
dxl) 
dxl) 
dxl) 
dxl) 
dxl) 
dxl) 

dxl : place -var *place- Canada*) 
dxl) 

dx-adj "Peoples Republic of China ^' 
dx-adj "P.R. China") 



: dx-adj " People * s 



(co 


"Colombia" 


:dxlc) ; Clumbia mis 


(cr 


"Costa Rica" 


:dx2) 


(cu 


"Cuba" 


:dxlc) 


(cy 


"Cyprus " 


:dxl) 


(cz 


"Czech Republic" :dx2 :dx "Czech" 


(dk 


"Denmark" 


:dxl) 


(ec 


"Ecuador" • 


:dxl) 


(eg 


"Egypt" 


:dxl) 


(ee 


"Estonia" 


:dxl) 


(et 


"Ethiopia" 


:dxl) 


(fi 


"Finland" 


:dxl) 


(fr 


"France" 


:dxl) 


(ge 


"Georgia" 


:sus-helpx "Georgia" 


AND- CO ge) 




(de 


"Germany" 


:dxl) 



:dx "Czechoslovakia" :tld cs) 



-NOT- CO us :dx-helpx "Georgia* 
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(gr "Greece" 
(gt "Guatemala" 

(ht "Haiti" 
(hn "Honduras" 
(hk "Hong Kong" 
(hu "Hungary" 
(is "Iceland" 
(in "India" 
(id "Indonesia" 
(ie "Ireland" 
ireland*) 

(il "Israel" 
(it "Italy" 
(jm "Jamaica" 
(jp "Japan" 
(jo "Jordan" 
(ke "Kenya" 
(kr "Korea" 
(kw "Kuwait" 
(lb "Lebanon" 
(ml "Mali" 
(my "Malaysia" 
(mx "Mexico" 
CO us 

(nl "Netherlands " 
(nz "New Zealand" 
(ni "Nicaragua" 
(no "Norway" 
(pk "Pakistan" 
(pa " Panama " 
(pe "Peru" 
(ph "Philippines" 
(pi "Poland" 
(pt " Portugal " 
(ro "Romania" 
(ru "Russia" 
(sa "Saudi Arabia" 
( sg " S ingapore " 
(za "South Africa" 
(es "Spain" 
(se "Sweden" 
(ch "Switzerland" 
(sy "Syria" 
(tw "Taiwan" 
CO cn) 

(tz "Tanzania" 
(th "Thailand" 
(tr "Turkey" 
(ug "Uganda" 
"Ukraine" 



dxl) 

dxl) 

dxl) 

dxl) 

dx2) 

dxl) 

dxl) 

dxlc) 

dxl) 

sus-helpx "Ireland" 



-NOT- st ni : place -var *place- 



dxlc) ; "Israel Morgenstern Ctr for,."? 
dxl :dx "Italia") 

dxlc :sus~helpx "Jamaica" -NOT- ci "Jamaica Plain") 
dxl) 

sus-helpx "Jordan" -NOT- co wg) 
dxl) 

dxl :tld kp) 
dxl) 

dxlc) ; Cedars of Lebanon; Lebanon, NH 

dxl) 

dxl) 

sus-helpx "Mexico" -NOT- st nm) ; may be better as NOT 



Zealand in Denmark 



Panama City, 
Peru, IN 



FL 



(ua 
(ae 

(ve 
(vn 
(yu 
(zm 



"United Arab Emirates" :dx2) 



dxl) 
dx2) 
dxl) 
dxl) 
dxl) 
dxlc) 
dxlc) 
dxl) 
dxl) 
dxl) 
dxl) 

dxl :tld su 
:dx2) 
dxl) 

:dx2 :dx-adj 

dxl) 

dxl) ; Sweden Hospital? 

dxl) 

dxl) 

dxl :dx-adj "ROC." :dx-helpx "Republic of China" 

dxl) 
dxl) 
dxl) 
dxl) 
dxl) 



:sus "USSR" :sus "Soviet") 



"Orange Free State") 



-NOT- 



" Venezuela" 
"Viet Nam" ^ 
" Yugoslavia" 
"Zambia" 
(zr "Zaire" 
(zw "Zimbabwe" 



dxl) 

dx2) 

dxl 

dxl) 

dxl) 

dxl) 



dx "Serbia" :dx "Montenegro") 



(ad "Andorra" :dxl) 

(af "Afghanistan" :dxl) 

(al "Albania" :dxl) 
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(am "Armenia" :dxl) 
(ao "Angola" ;dxl) 
(az "Azerbaijan" :dxl) 

(ba "Bosnia and Herzegowina" :dx "Bosnia" :dx "Herzegowina" :dx 
"Herzegovina" ) 

(bf "Burkina Faso" :dx2) 
(bh "Bahrain" :dxl) 
(bi "Burundi" :dxl) 
(bj "Benin" :dxl) 

(bn "Brunei Darussalam" :dx "Brunei") 
(bt "Bhutan" :dxl) 
(bw "Botswana" :dxl) 
(by "Belarus" :dxl) 
(bz "Belize" :dxl) 

(cf "Central African Republic" :dx2) 
(eg " Congo " : dxl ) 

(ci "Ivory Coast" :dx2 :dx-adj "Cote d'lvoire") 

(cm "Cameroon" :dxl) 

(dj "Djibouti" :dxl) 

(do "Dominican Republic" :dx2) 

(dz "Algeria" :dxl) 

(eh "Western Sahara" :dx2) 

(er "Eritrea" :dxl) 

( ga " Gabon " : dxl ) 

(gf "French Guiana" :dx2) 

(gh "Ghana" :dxl) 

(gi "Gibraltar" :dxl) 

(gl "Greenland" :dxl) 

(gm "Gambia" :dxl) 

(gn "Guinea" :dx-helpx "Guinea" -NOT- 2 (co gw co gq) ) 

(gp "Guadeloupe" :dxl> 

(gq "Equatorial Guinea" :dx2) 

(gw "Guinea-Bissau" :dxl :dx-adj "Guinea Bissau") 

(gy "Guyana" :dxl) 

(hr "Croatia" :dxl) 

(iq "Iraq" :dxl) 

(ir "Iran" :dxl) 

(kg "Kyrgystan" :dxl) 

(kh "Cambodia" :dxl) 

(kz "Kazakhstan" :dxl) 

(la "Laos" -:dxl :dx-all "Lao Republic") 

(li "Liechtenstein" :dxl) 

(Ik "Sri Lanka" :dx2) 

(Ir "Liberia" :dxl) 

(Is "Lesotho" :dxl) 

(It "Lithuania" :dxl) 

( lu " Luxembourg " : dxl ) 

(Iv "Latvia" :dxl) 

(ly "Libya" :dxl) 

(ma "Morocco" ;dxl) 

(mc "Monaco" :dxl) 

(md "Moldova" :dxl) 

(mg "Madagascar" :dxl) 

(mk "Macedonia" :dxl) 

(mm "Myanmar" :dxl) 

(mn "Mongolia" :dxl) 

(mo "Macau" :dxl) 

(mt "Malta" :dxl) 

(mw "Malawi" :dxl) 

(mr "Mauritania" :dxl) 

(raz "Mozambique" :dxl) 
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(na "Namibia" :dxl) 
(ne "Niger" :dxl) 
(ng "Nigeria" :dxl) 
(np "Nepal" :dxl) 
(om "Oman" :dxl) 
(ps "Palestine" :dxl) 
(py "Paraguay" :dxl) 
(qa "Qatar" :dxl) 
(rw "Rwanda" :dxl) 
(sd "Sudan" :dxl) 
(si "Slovenia" :dxl) 

(sk "Slovakia" :dxl :dx-adj "Slovak Republic") 

(si "Sierra Leone" :dx2) 

(sm "San Marino" :dx2) 

(sn "Senegal" :dxl) 

(so "Somalia" :dxl) 

(sr "Surinam" :dxl) 

(sv "El Salvador" :dx2) 

(sz "Swaziland" :dxl) 

(td "Chad" :dxl) 

(tg "Togo" :dxl) 

(tj "Tajikistan" :dxl) 

(tm "Turkmenistan" :dxl) 

(tn "Tunisia" :dxl) 

(tp "East Timor" :dx2) 

(uy "Uruguay" :dxl) 

(uz "Uzbekistan" :dxl) 

(va "Vatican City" :dx2 :dx~adj "Holy See") 

(wg "Western Jordan and Gaza" :dx-adj "Western Jordan" :dx "Gaza 
(ye " Yemen " : dxl ) 

(ac "Atlantic islands" :dx-island "Ascension" 
:tld bm :dx "Bermuda" 
:tld bv :dx-island "Bouvet" 
:tld cv :dx-adj "Cape Verde" 

:tld fk :dx-islands "Falkland" :dx "Falklands" 

:tld fo ;dx-islands "Faroe" 

:tld St :dx-all "Sao Tome Principe" 

:tld sh :dx-adj "St. Helena" :dx-adj "St Helena" 

:t.ld pm :dx-all "St Pierre Miquelon" 

:tld gs :dx-islands "South Georgia" :dx-islands "South Sandwich 
) 

(as "Pacific islands" :dx-adj "American Samoa" 



tld 


cx 


:dx-island "Christmas" 


tld 


ck 


: dx-islands "Cook" 


tld 


fj 


:dx "Fiji" 


tld 


pf 


:dx-adj "French Polynesia" 


tld 


gu 


:dx "Guam" 


tld 


ki 


:dx "Kiribati" 


tld 


mh 


: dx- is lands "Marshall " 


tld 


fm 


:dx "Micronesia" 


tld 


nr 


:dx "Nauru" 


tld 


nc 


:dx-adj "New Caledonia" 


tld 


nu 


:dx "Niue" 


tld 


nf 


:dx- island "Norfolk" 


tld 


mp 


: dx-islands "Northern Mariana" 


tld 


pw 


:dx "Palau" 


tld 


pg 


:dx-adj "Papua New Guinea" 


tld 


pn 


:dx "Pitcaim" 


tld 


ws 


:dx "Samoa" 


tld 


sb 


: dx-islands "Solomon" 
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:tld tk :dx "Tokelau" 

:dx "Tonga" ; :tld to is being sold out 

:dx "Tuvalu" ; :tld tv is being sold out 

:tld urn ; United States Minor Outlying Islands 

:tld vu :dx "Vanuatu" 

:tld wf :dx-islands "Wallis and Futuna" 
) 

(aw "Caribbean islands" :dx2 :dx "Aruba" 



tld 


ai 


:dx 


"Anguilla" 


tld 


ag 


:dx 


"Antigua" :dx "Barbuda" 


tld 


bs 


:dx 


"Bahamas" 


tld 


bb 


:dx 


"Barbados" 


tld 


ky 


:dx- 


islands "Cayman" 


tld 


dm 


:dx 


"Dominica" 


tld 


gd 


:dx 


"Grenada" 


tld 


mq 


:dx 


"Martinique" 


tld 


ms 


:dx 


" Mont ser rat" 


tld 


an 


:dx- 


adj "Netherlands Antilles" 


tld 


pr 


:dx- 


adj "Puerto Rico" 


tld 


kn 


:dx- 


all "St Kitts" ; ignore Nevis 


tld 


Ic 


:dx- 


adj "Saint Lucia" 


tld 


vc 


:dx- 


adj "Saint Vincent" :dx "Grenadines" 


tld 


tt 


:dx- 


all "Trinidad Tobago" 


tld 


tc 


:dx- 


all "Turks Caicos" 


tld 


vg 


:dx- 


adj "Virgin Islands" ; British 


tld 


vi 


; American 



) 

(km "Indian Ocean islands" :dx "Comoros" 
:tld io :dx-adj "British Indian Ocean Territory" 
:dx-island "Cocos" :dx-island "Keeling" ; :tld cc for sale 
:tld tf :dx-adj "French Southern Territories" 
:tld hm :dx- island "Heard" :dx-island "McDonald" 
:tld mv :dx "Maldives" 
:tld mu :dx "Mauritius" 
:tld yt :dx "Mayotte" 
:tld re :sus "Reunion" 
:tld sc :dx "Seychelles" 
) 

(aq "Remote regions" :dx "Antarctica" 
:tld nt :dx-adj "Neutral Zone" 

:tld sj :dx~island "Svalbard" :dx~island "Jan Mayen" 
) 

)) 

(boot: : load-logical -path-file "source : states") 
®®file hello ♦html 

<html> 

<head> 

<title>Hello World</title> 

</head> 

<body> 

<center><h3>Getting the Webserver to Say Hello</h3></center> 
<P> 

<f orm action=="http : //lO . 1 . 0 . 4/cgi-bin/l . cgi " > 
<input type=." hidden" name="fn" value="say_hello"> 

<table> 
<tr> 

<td valign="top"><b>Say it:</b></td> 
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<td valign="top"> 

<input type="radio" name= "repetition" value="l" CHECKED>Once 
<br> 

<input types! "radio" name= "repetition" value="2">Twice 
<br> 

<input type="radio" name= "repetition" value="3">Three times 
<br> 

<input type-"radio" name = "repetition" value-"4 ">Four times 

</td> 

</tr> 

<tr><td>&nbsp ; </td></tr> 
<tr> 

<td colspan="2" align= "center" >< input type=" submit "></td> 

</tr> 

</table> 

</ f orm> 
</body> 
</html> 

®@file lisp -macros 

;;; Adapted from Norvig p. 337. (C) 1999-2000 by John Sotos, All Rights 
Reserved. 

; ; ; My additions : deconstructor-f n parameter 

;;; erase- < resource > method 

;;; al locate -mas s -<resource> method 

;;; < print -alloc-p > and notfication of allocation 

(defmacro defresource (name &key constructor 

(initial-copies 0) 
(size (max initial -copies 10) ) 
(extension- size (max 10 (floor size 2))) 
(destructor-fn #' identity) ) 
"< constructor > should be a form, eg (make-record :rect) 
< destructor-fn > should be a function of one argument, eg 
#• (lambda (x) (dispose-recond x) ) . This function is applied to all 
resources in the resource storage *up to the fill pointer*. In other 
words, anything that has been allocated and remains allocated will not 
be clobbered." 
(f let ( (symbol {&rest args) 

(declare (dynamic -extent args) ) 

"Concatenate symbols or strings to form an interned symbol. Norvig 

p. 302" 

(intern (format nil "-.{-a-}" args)))) 
(let ((resource (symbol name '-resource)) 

(deallocate (symbol 'deallocate- name)) 
(allocate (symbol 'allocate- name)) 

(allocate-mass (symbol ' allocate-mass- name)) 
(erase (symbol 'erase- name)) 

# -production-system 

(inspect (symbol 'inspect- name)) 

# -production- system 
(length- (symbol 'length- name)) 

(extensionsize (gensym) ) ) 
^ (let ((, resource (make-array ,size : fill-pointer 0 :adjustable t) ) 
(, extensionsize , extension- size) 
(print-alloc-p t) ) 

(defun , allocate () 

"Get an element from the resource pool, or make one." 
(if (= (fill-pointer , resource) 0) 
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(progn 
#-production-system 
(when print -alloc -p 
#+hera 

(format t "-%;;; Allocating -S #-S-" (quote ,name) (length 

, resource) ) 

; (princ , (concatenate 'string #. (string #\Newline) 
"Allocating " (symbol -name name) ) ) 
) 

, constructor) 
(vector-pop , resource) ) ) 

(def un , deallocate ( , name) 

"Place a no -longer -needed element back in the pool." 
(vector-push-extend ,name ^resource ,extensionsize) ) 

(defun y erase {) 

"Destroys all unallocated resources without freeing the storage." 
; ; Use of < map > ensures that only the visible part of the 
;; resource vector is processed, 
(map nil ,destructor-fn , resource)) 



# -production- system 
(defun , inspect () 
(inspect , resource) ) 

# -produc t ion- sys t em 
(defun , length ( ) 
(length , resource)) 



(defun , allocate-mass (n) 

; ; Ensures < n > unused pre -formed resources available in resource 

stack. 

(let ( (n-new (- n (fill-pointer , resource) )) ) 
(dotimes (i n~new) 
( , allocate) ) ) ) 



, (when {> initial-copies 0) 

" ( , allocate-mass , initial- copies) ) 
' ,name) ) ) ) 

» • • — — — — _ — — _ — — ^ __ 



;;; LISP MACROS 



(def macro dovec ( (elt index vec) &body body) 
(let ( (vecvar (gensym) ) ) 
"(let (,elt 

{ , vecvar , vec ) ) 
(dotimes (, index (length ^ vecvar)) 
(setq ,elt (aref , vecvar , index)) 
,®body) ) ) ) 



(defmacro let-de (args &body body) 
" (let ,args 

(declare , (cons 'dynamic -extent (mapcar #' first args))) 
, ©body) ) 

(defmacro let*de (args &body body) 
"(let* ,args 
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(declare , (cons 'dynamic -extent (mapcar #• first args) ) ) 
, ©body ) ) 

#1 

(def macro -biggest-key-value (sequence ^optional (key #' identity) ) 
"Use this for arrays. Use < biggest -key-val > for lists*" 
"(reduce #'max , sequence :key ,key)) 

(def macro -capl (string) 

" (string-upcase , string :start 0 :end 1)) 

(def macro -half (x) ; could be speed optimized, I'm sure. 

" (floor ,x 2) ) 

(def macro -kwote (form) 
"(list 'quote ,form)) 

(defmacro -the-last (list) 
"(car (last , list) ) ) 

i# 

;;; mml (991222) first version in heracd directory. Prior was in oou. 
@®file masterpick 

(defun search-view-html (thread search) 
(let ( (tally (search-tally search) ) ) 

(setf (tally-wts tally) (def ault-pf choice 'wts) 
(tally-geo tally) (def ault-pf choice *geo) 
(tally-srt tally) (def ault-pf choice 'srt) 
(tally-fmt tally) (def ault-pf choice 'fmt) 
(tally-max tally) (def ault-pf choice 'max) ) 
(vtl thread tally) ) ) 



(def parameter *sta-key* «STA) ; used in VT lambda list 

(def parameter *def ault-sta* 0) ; Lispy start counting from zero 

(defcgifn vt (tk wts geo srt fmt max sta) ; sta = *sta-key* 
vt = view thing 
tk = tally key 
wts =^ what to show 
geo = geography filter 
srt = sort -by criterion 
fmt = format for display 
max =s max to show 
(let ( (tally ( tally- from-tallykey (read-f rom-string tk) ) ) ) 

(setf (tally-wts tally) (get-pickf ield-choice 'wts (read-f rom-string 
wts) ) 

(tally-srt tally) (get-pickf ield-choice 'srt (read-f rom-string 

srt) ) 
fmt)) 
max) ) 
geo) ) 
geo) ) ) 



(tally-fmt tally) (get-pickf ield-choice » f mt (read-f rom-string 
(tally-max tally) (get-pickf ield-choice 'max (read-f rom-string 
(tally-geo tally) (or (get-pickf ield-choice 'geo (read-f rom-string 

(new-geo-pf choice tally geo (read-f rom-string 
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(tally-sta tally) (if (zerop (length sta) ) *def ault-sta* (read- 
from-string sta) ) 
) 

(vtl thread tally) ) ) 

(defhtmfn vtl (thread tally) :props nil 

; ; Cannot make the assumption that a pf choice will always be a member of 
;; pickfield choices! (search-all-files on this comment to see why) 

7 7 

(with-new-page (thread : title (format nil * ~A * -A" 

(tally-filename tally) 
(pf choice -name (tally-geo tally) ) 
(pf choice-name (tally-wts tally) ) ) ) 
(princt "<table cellpadding= * 5 • width= • 100% ♦ xtrxtd bgcolor= ' 99cc99 ' >" 
thread) 

(breadcrumb thread tally (tally-geo tally) ) 

(emit-pickf ield-area thread tally) 
(princt "</td></tr></table>" thread) 
(emit -pagemeat -area thread tally) ) ) 

(defmethod new-geo-pf choice (tally geostring (node-num integer) ) 
(declare (ignore geostring)) 

(let* ( (node (node -from- node-num tally node-num) ) 

(name (format nil "in -A" (node -print -name node) ) ) 

(nodeplace (node-place node) ) ) 
(make -geonode-pf choice :pickf ieldkey *GEO 

: key node - num 
: name name 
: name 2 name 

: filter (if (unclassified-node -p node) 

#• (lambda (p) (place2-is-or-isin-placel 
(place- superplace 

nodeplace) p) ) 

#» (lambda (p) (place2-is-or-isin-placel 

nodeplace p) ) ) ) ) ) 

(defmethod new-geo-pf choice (tally authomame garbage) 
(declare (ignore tally garbage)) 
(make -geoname-pf choice :pickf ieldkey ' GEO 

:key (escape -author-name authorname) 
: name authomame 

:name2 (format nil "of -A" authomame) ) ) 

(defun geonode-pf choice -node (pfc tally) 

(node-from-node-num tally (pf choice-key pfc))) 



1 

(defun emit -pagemeat -area (thread tally) 
(cond 

( (fmt -shows -debug -p tally) 
(if (geoname-pf choice-p (tally-geo tally) ) 
(formatt thread "Nope.") 
(output -by -paper thread tally) ) ) 

( (geoname-pf choice-p (tally-geo tally) ) 
(explode -author thread tally (pf choice -name (tally-geo tally) ) ) ) 

( (wts-is-people-p tally) 
(print -authors thread tally) ) 
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( (wts -is -papers -p tally) 
(print -papers thread tally) ) 

(t 

(let* ({wts (tally-wts tally)) 

(geo (tally-geo tally) ) 

(dispnodes (findnodes thread 

(pf choice-filter wts) 
(pfchoice- filter geo) 
nil 

(node -subs 
(f indnode-startnode geo tally) ) ) ) ) 

(if (< (length dispnodes) 2) 
(progn 

(setf (tally-wts tally) *paper-wtc-pf choice*) 
(vtl thread tally) ) 
(emit-pagemeat-areal thread tally 

(sort dispnodes (pf choice-filter ( tally- srt 

tally) ) ) 

wts) ) ) ) ) ) 



(def method f indnode-startnode (pfc tally) 
(declare (ignore pfc) ) 
(tally-root-node tally) ) 

(defmethod f indnode-startnode ( (pfc geonode -pfchoice) tally) 
(geonode-pfchoice-node pfc tally) ) 

(defparameter *min-display-score* 1) 

(defun findnodes (thread wts-filter geo-filter toshow nodes) 
(if (endp nodes) 
(values toshow) 

( symbol -macrolet ( (nodel (first nodes)) 

(placel (node-place (first nodes)))) 
(cond ((null (funcall wts-filter placel)) 

(findnodes thread wts-filter geo-filter 

(findnodes thread wts-filter geo-filter toshow (node- 
subs nodel) ) 

(rest nodes) ) ) 
((or (null (funcall geo-filter placel)) 

(< (node-total-score nodel) *min -display- score*) ) 
(findnodes thread wts-filter geo-filter toshow (rest nodes))) 
(t 

(findnodes thread wts-filter geo-filter (cons nodel toshow) 
(rest nodes) )))))) 



(defparameter *number-subl ink -nodes* 3) 

(defun emit-pagemeat-areal (thread tally nodes wts) 
(with- thread-output (stream thread) 

(let* ( (worldwide-max-score (worldwide -max -score tally wts)) 

(mag (calculate -score-bar-magnification nodes worldwide-max- 
score) ) 

(min-di splay- score *min-display-score*) ) ; could be parameterized 

someday 

(flet ((Inode (node) 

(when (>= (node-total-score node) min-display-score) 
(foinnat stream "-%<tr><td align= ' right • >") 
(score-bar thread mag (node -total -score node)) 
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(princ "</td><td>" stream) 

(node-link thread tally node 1) 

(ecase (pf choice-key (tally-fmt tally)) 

(si (princ "</td></tr>" stream)) 

(sp (princ "</td><td>" stream) 

(node-link-subs thread tally node 1 *number-siiblink- 

nodes*) 

(princ "</td></tr>" stream)) 
(tr (princ "</td></tr><tr><td></td><td>" stream) 

(node-link-subtree thread tally node 1 # ' institution- 

P) 

(princ "</td></tr>" stream)))))) 
(format stream "-%<table>") 

(map nil #'lnode nodes) ; < nodes > may be list or vector 
(format stream "-%</table>") 

(worldwide -bar thread mag worldwide -max- score (pf choice -name 2 
wts)))))) 

(defun worldwide -bar (thread mag worldwide -max- score name) 

(formatt thread "-%<table><tr><td valign=: 'middle • >«) 

(score-bar thread mag worldwide -max- score) 

(formatt thread "</td><td> <-- Max score for --A 
worldwide . </td></tr></table> " 
name) ) 



(defun explode-author (thread tally authorname) 
(let* ( (au (get-author-rec tally authorname) ) 
(papers (author-allpapers au) ) 
(leafplaces (author- leaf places au) ) ) 
(with -thread -output (stream thread) 
(princ "<blockquote>" stream) 

; ; Name 

(format stream "-.%<b><big>-A</big></b>« authorname) 
; ; j:jOcation(s) 

(format stream "«%<p>IiOcation(s) :<ul>") 
(if leafplaces 

(delist (p leafplaces) 
(princ "<li> " stream) 
(breadcrumb -up thread tally p t) ) 
(princ "<li> None could be determined." stream)) 
(format stream «-%</ul>") 

; ; (maybe) email address 

(let ((emails (remove-if #'null 

(mapcar # *paper-email ( author -firstauthorpapers 

au) ) ) ) ) 

(when emails 

(format stream ••-%<p>Possible email address (es) : <ul>~ 

-{-%<li> <a href=:'mailto:--A'>-:*-A</a>-}-' 
~%</ul>" 

(remove-duplicates emails :test #' string -equal) )) ) 

; ; Coauthors 
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(format stream "-%Co -authors/ with number of co-authored 
papers : <blockquote> " ) 

(let ({coauthors nil)) 
(delist (paper papers) 

(dolist (coauthor (paper- allauthors paper) ) 
(unless (eql coauthor au) 

(let ( (rec (find coauthor coauthors :key first))) 
(if rec 

(incf (second rec) ) 

(push (list coauthor 1) coauthors)))))) 
(if (null coauthors) 
(princ "None." stream) 
(progn 

(setq coauthors (sort coauthors #•> :key #* second)) 
(person-link thread tally (caar coauthors) ) 
(format stream " (-D) " (second (first coauthors))) 
(dolist (co (rest coauthors) ) 

(format stream " · ") 

(person- link thread tally (first co) ) 

(format stream " (-D) " (second co) ) ) ) ) ) 
(format stream "-%</blockquote>" ) 

( format stream " -%<hr>Papers : " ) 

(print -papers thread tally (coerce papers • vector) ) 
(princ "</blockc[uote>" stream)))) 

1 1 t " ~ 

1 

(defun print -papers (thread 

tally 
&optional 
(papers 

(sort (papers -to-show tally (pf choice -filter (tally-geo 

tally) ) ) 

# • > :key # 'paper- score) ) ) 
(let ((len (length papers) ) 

(maxx (reduce #'max (tally-paperdata tally) :key # 'paper- score ) ) 
(start (tally-sta tally)) 
mag) 

(setf (tally-sta tally) *default-sta*) ; to help optimization in NODE- 
LINK 

(setq mag (calculate -score -bar-magnificat ion 

nil tnaxx :max-score-to-display (reduce #'max papers :key 
#* paper-score) ) ) 

(with- thread -output (stream thread) 
(format stream "-%<table>") 

(dotimes (i (things -per -page -bar thread stream tally len "Papers" 
start) ) 

(let* ( (paper (aref papers (+ i start) ) ) 

(leaf places (paper- leaf places paper) ) ) 
t i * 

;; score bar and title line. 

(format stream "-%<tr><td align= ' right * valign= • top * >" ) 
(score -bar thread mag (paper- score paper) ) 

(format stream "</td><td>-A (-D) " (paper-title paper) (paper-year 

paper) ) 

(html -image -tag thread "pm.gif" : border "0") 
(format stream "</td></tr>" (paper-title paper)) 
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(format stream " -'%<tr><td></td><td>" ) 
(dolist (name (paper -authornames paper) ) 

(person-link thread tally (get-author-rec tally name) ) 

(princ "  " stream) ) 
(format stream "</td></tr>") 

(format stream "-%<tr><td></td><td>-'A</td></tr>" (paper -address 

paper) ) 

; ; Breadcrumbing line 

(format stream "-'%<tr><td></td><td>«) 
(dolist (p leaf places) 

(princ "<small>[ " stream) 

(breadcrumb -up thread tally p t) 

(princ " 3 </small>" stream)) 
(format stream "</td></tr>") 

; ; Separator bar 
7 / 

(format stream "~%<tr><td colspan= • 2 « ><hr></td></tr>" ) 
)) 

(format stream "</table>") 

(worldwide -bar thread mag maxx "a paper") 

(things-per-page-bar thread stream tally len "Papers" start)))) 



(defun print-authors (thread tally) 

(let* {(authors (find-authors tally (pf choice-filter (tally-geo tally)))) 
(len (length authors)) 

(maxx 0) 

(start (tally-sta tally) ) 
mag) 

(setf (tally-sta tally) *def ault-sta*) ; to help optimization in NODE- 
LINK 

(maphash #' (lambda (key author-rec) 
(declare (ignore key) ) 

(setq maxx (max maxx (author-score author-rec) ) ) ) 
(tally-authordata tally) ) 
(setq mag (calculate-score-bar-magnif ication 

nil maxx : max- score -to -display (reduce S'maLJc authors :key 
# ' author- score) ) ) 

(with- thread -output (stream thread) 
(format stream "~%<table>") 

(dotimes (i (things-per-page-bar thread stream tally len "People" 
start) ) 

(let ((au (aref authors (+ i start)))) 

7 7 

; ; score bar and author link 

7 7 • 

(format stream "~%<tr><td align= ' right ' >") 
(score-bar thread mag (author-score au) ) 
(format stream "</td><td>") 
(person-link thread tally au) 
(format stream "</td>") 

; ; location breadcrumbing 
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(raultiple-value-bind (leafplaces certaintylevel) 

(author-leafplaces au) 
(case certaintylevel 

(1 (breadcrumb-authorplaces-in-cell thread stream tally 

leafplaces nil)) 

(2 (breadcrumb-authorplaces-in-cell thread stream tally 

leafplaces t) ) 

(3 (format stream 

"<td><small>??</small></td><td><small>-{ [ (-A-) 

]~}</small></td>" 

leafplaces) ) 

(4 (princ "<td><small>?</small></td><td><small>?</small></td 

stream) ) ) ) 

; ; end table row 

(princ "</tr>" stream))) 
(format stream "</table>") 

(worldwide -bar thread mag maxx "a person")))) 

(defun author-leafplaces (au) 
Returns two values: 

(a) a list of leafplaces, which may be NIL. 

(b) the "category" of the leaf place answer. 
l«got places from papers on which author was first author, 

2=got places from papers on which author was not first author, 
3=got places from the CY fields of all the authors papers, 
4=no places. 

(let ( (leafplaces (f ind-leaf places -for-papers { author- fir stauthorpapers 

au) ) ) ) 

(if leafplaces 

(values leafplaces 1) 

(if (setq leafplaces (find- leafplaces -for-papers ( author -allpapers 

au))) 

(values leafplaces 2) 

(if (setq leafplaces (mapcar # 'paper- coimtry (author- allpapers au) 
(values (remove-duplicates leafplaces :test #• string -equal) 3) 
(values nil 4)))))) 

(defun breadcrumb-authorplaces-in-cell (thread stream tally leafplaces 
questionp) 

(princ (if questionp 

"<td><small>?</small></td>" 
"<td></td>") 
stream) 

(princ «<td><small>" stream) 
(delist (place leafplaces) 
(princ " [ " stream) 

(breadcrumb-up thread tally place t) 
(princ " ] " stream) ) 
(princ "</small></td>" stream)) 

(defun find-authors (tally geo-filter) 

(let ((authors (make-array 1000 :adjustable t : fill-pointer 0))) 
(dovec (paper i (papers -to-show tally geo-filter)) 
(delist (author-rec (paper- allauthors paper) ) 
(when (not (find author-rec authors) ) 

(vector-push-extend author-rec authors)))) 
(sort authors #'> :key #' author-score) ) ) 

(defun author-details (stream au) 
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(format stream 

"<p><tt>-4, ' OD -D -D </tt><a 
href = • j avascript :pm ( \ " -A- { , -A- } \ « ) ' >-'A</a> " 
(author-score au) 
(length (author-allpapers au) ) 
(length (author- firs tauthorpapers au) ) 
(length (author -las tauthorpapers au) ) 
(paper-pmid (first ( author -allpapers au) ) ) 
(mapcar #«paper-pmid (rest (author-allpapers au) ) ) 
(author-name au) ) ) 

(defun paper-details (stream au address -papers) 

(dolist (paper (sort (copy-seq (author -allpapers au) ) #'> :key #'paper- 
year) ) 

(format stream "--%<br><tt>    -A </tt>-A (-D) " 
(if (member paper address -papers :test #*eql) "tobsp;") 
; (paper- score paper) 
(paper-title paper) 
(paper-year paper) ) ) ) 

/// *" 
1 

; ; ; This is "debug" output 

(defun output-by-paper (thread tally) 
( output -by-paper2 thread tally 0)) 

(defcgifn output- by -paperl (tallykey start) 
(output -by-paper Ih thread 

(tally-from-tallykey (read- from- string tallykey) ) 
(read- from- string start) ) ) 
(defhtmfn output -by- pap erlh (thread tally start) :props nil 
(with-new-page (thread : title (tally- filename tally)) 
(output -by-paper 2 thread tally start))) 

(defun output -by -paper2 (thread tally start) 

(let* ({papers (papers -to -show tally (pf choice-filter (tally-geo 

tally) ) ) ) 

(len (length papers) ) ) 

(with- thread-output (stream thread) 

(dotimes (i (paper- counter-bar thread stream tally len start) ) 
(let ({paper {aref papers {+ i start)))) 

(format stream "-%<hr><tt>-7, 2F </tt>-A E-A3-'%<ul>" 
(paper-year paper) 

(or (paper-address paper) no address given --") 

(paper-country paper) ) 
(format stream "-%<br>Email address: -A" (paper-email paper)) 
(dolist (rule (paper-rules paper) ) 
(format stream "-%<li> <small>") 
;THIS IS GIVING A PROBLEM 

(node-link thread tally (find-place-node (rule-place rule) tally) 

0) 

(format stream '* ** -'S</small>" rule)) 
(princ "</ul>" stream))) 
(paper-counter-bar thread stream tally len start) ) ) ) 

(defun papers -to -show (tally geo-filter) 

(let ((papers (make-array 1000 radjustable t : fill-pointer 0))) 
(dovec (paper i (tally-paperdata tally) ) 

(dolist (leafplace (paper- leaf places paper) ) 
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; (dbp (place-key leafplace) (if (fxincall geo-f ilter leafplace) t 

nil)) 

(when (funcall geo- filter leafplace) 
(vector-push-extend paper papers) 
(return) ) ) ) 
(values papers) ) ) 

(defun paper-counter-bar (thread streem tally npapers start) 
(let* ( (papers -per-page (pf choice-filter (tally-max tally))) 
(n (min papers -per-page (- npapers start)))) 
(format streem "'-%<hr>Papers -D-'-D." (1+ start) (+ start n) ) 
(dotimes (i (ceiling npapers papers -per-page) ) 
(let ( ( j (* i papers -per-page) ) ) 
(princ "   " streem) 
(unless (= start j) 

(cgi-anchor thread »OUTPUT-BY-PAPERl 

•tallykey (tally-key tally) 
« start j ) ) 

(format streem "-D — D« (1+ j) (min npapers (+ j papers -per-page) ) ) 
(unless (= start j) 

(princ "</a>" streem)))) 
(values n) ) ) 

(defun things -per-page-bar (thread streem tally nthings thingsname start) 
(let* ( (things -per-page (pf choice-filter (tally-max tally) ) ) 

(n (min things -per-page (- nthings start)))) 

(unless (and (zerop start) 
(= n nthings) ) 

(format streem "~%<hr><b>~A ~D-~D</b>" thingsname (1+ start) (+ start 



n)) 



(dotimes (i (ceiling nthings things -per-page ) ) 
(let* ( ( j (* i things-per-page) ) 

(group (format nil "~d--D" 

(1+ j) (min nthings (+ j things-per-page))))) 
(princ " · " streem) 
(if (= start j) 

(princ group streem) 

(start-link thread tally group j)))) 
(princ "<hr>" streem) ) 
(values n) ) ) 



(defun worldwide-max-score (tally wts) 
(let ( (nodes (tally-nodes tally) ) 

(thing-filter (pf choice-filter wts))) 
(if (plusp (length nodes) ) 

(reduce #*max nodes :key (lambda (node) 

(if (and (funcall thing-filter (node-place 

node) ) 

(not (unclassif ied-node-p node))) 
(node -total -score node) 
0))) 

1))) 

(defun calculate-score -bar-magnification 
( di sp 1 ay - node s wor 1 dwi de - max - score 

&key (max-score-to-display (reduce #»max display-nodes 

:key # 'node -total - 

score) ) ) 
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;; Reduce the magnification if the worldwide bar would be too huge, 
(let* ( (max-bar-width 70) 

(mag (/ max-bar-width meix -score- to -di splay) ) ) 
(when (> (* mag worldwide -max- score) 450) 
(setq mag (/ 450 worldwide-max-score) ) ) 
(values mag) ) ) 

(defun score-bar (thread mag score) 

(let ((blackwidth (max 1 (round (* mag score))))) 

(html-image-tag thread "lxlblack.gif" :width blackwidth :height 8))) 



(defun node-link (thread tally node nlevels) 
(DECLARE (IGNORE NLEVELS)) 

(declare (special * window- root -node -key*) ) 
(with-slots (wts geo srt fmt max sta) tally 

(cgi-anchor-with-text thread (node -print -name node) 

»VT 

»TK (tally-key tally) 
(pf choice-pickf ieldkey wts) 
(pf choice-pickf ieldkey geo) 
(pfchoice-pickf ieldkey srt) 
(pfchoice-pickf ieldkey fmt) 
(pfchoice-pickf ieldkey max) 



(wts -right level node) 
(node -number node) 
(pf choice-key srt) 
(pfchoice-key fmt) 
(pf choice -key max) ) ) ) 



(defun start -link (thread tally text startnum) 
(declare (special * window- root -node -key* ) ) 
(with-slots (wts geo srt fmt max sta end) tally 
(cgi-anchpr-with-text thread text 

»VT 

»TK (tally-key tally) 
(pfchoice-pickf ieldkey wts) 
(pfchoice-pickf ieldkey geo) 
(pfchoice-pickf ieldkey srt) 
(pfchoice-pickf ieldkey fmt) 
(pfchoice-pickf ieldkey max) 
*sta-key* 

(defun person-link (thread tally author-rec) 
(declare (special *window- root -node -key*) ) 
(let ( (name (author-name author-rec) ) ) 

(with-slots (wts geo srt fmt max sta end) 
(cgi- anchor thread 
I VT 

'TK (tally-key tally) 
(pfchoice-pickf ieldkey wts) 

pf choice*) 

(pfchoice-pickf ieldkey geo) 
(pfchoice-pickf ieldkey srt) 
(pfchoice-pickf ieldkey fmt) 
.(pfchoice-pickf ieldkey max) 
*sta-key* 
(princt name thread) 

(html-image-tag thread "pm.gif" : border 
(princt "</a>" thread)))) 



(pfchoice-key wts) 
(pfchoice-key geo) 
(pfchoice-key srt) 
(pfchoice-key fmt) 
(pfchoice-key max) 
startnum) ) ) 



tally 



(pfchoice-key *paper-wtc- 

( escape -author -name name) 
(pfchoice-key srt) 
(pfchoice-key fmt) 
(pfchoice-key max) 
0) 

"0") 



(defun node -link- subs (thread tally node nlevels nprint) 

(let ((subs (sort (remove-if #*zerop (node-subs node) :key #' node-total ■ 
score) 
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(pf choice-filter (tally-srt tally))))) 

(when subs 

(formatt thread « [<small> ") 

(node-link thread tally (first siabs) (1+ nlevels) ) 
(dolist (sub (rest subs) ) 

(when (zerop (decf nprint) ) 
(return) ) 

(princt " * " thread) 

(node-link thread tally sub (1+ nlevels))) 
(when (nthcdr nprint subs) 

(princt " ..." thread) ) 
(princt " </small>] " thread) ) ) ) 

(defun node-link-subtree (thread tally node nlevels leaf -test-f n) 

(let ((subs (sort (remove-if #' zerop (node-subs node) :key #'node-total- 
score) 

(pf choice-filter (tally-srt tally))))) 
(dolist (sub subs) 

(unless (and nlevels 1) 

(eq sub (first subs))) 
(formatt thread «-'%<br>") ) 
(dotimes (i nlevels) 

(formatt thread "fenbsp;   fenbsp;**)) 
(node-link thread tally sub nlevels) 
(unless (funcall leaf -test-fn (node-place sub) ) 

(node -1 ink- sxibtree thread tally sub (1+ nlevels) leaf -test-fn) ))) ) 



(defun emit-pickf ield-area (thread tally) 
(cgi -form-start thread 'VT) 
(cgi- form-hidden thread 

»TK (tally-key tally)) 
(apply emit-pickf ield-menu 'wts thread (calc-pf cs-wts (tally-wts tally))) 
(apply #'emit-pickf ield-raenu 'geo thread (calc-pf cs-geo (tally-geo tally))) 
(apply #'emit-pickfield-raenu 'srt thread (calc-pf cs (tally-srt tally))) 

(formatt thread input types= « submit • value='Go' >-%<br>~%") 

(apply #'emit-pickfield-flat 'fmt thread (calc-pf cs (tally-fmt tally))) 

(apply #' emit-pickf ield-menu 'max thread (calc-pf cs (tally-max tally))) 

(princt "</form>" thread) ) 

(defun world-p (place) 

(placekey= (place-key place) 
*world-key*) ) 

#1 This fn was neat. If NYC was the window's underlying place, then 
this fn would prevent you from asking for countries in JSTYC. 
But it would also prevent you from asking for countries in the 
world, so I replaces it with vanilla < calc-pf cs >. 
(defun calc-pf cs-wts (pf choice place) 
(let ((nix (etypecase place 

(PIiANET nil) 
(COUNTRY • (oc) ) 

(STAYT • (oc ts) ) 

(CITY ' (oc ts ic) ) 

(INSTITUTION ' (oc ts ic ni) ) 
(PEOPIjE ' (oc ts ic ni ep) ) ) ) ) 

(list (remove-if #• (lambda (pfc-key) 

(member pfc-key nix) ) 
(built -in-pf choices pf choice) 
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:key #'pf choice-key) 

pf choice) ) ) 

i# 

(defun calc-pf cs-wts <pf choice) ; see above 
(calc-pf cs pf choice) ) 

(def method calc-pf cs-geo (pf choice) 
(calc-pf cs pf choice) ) 

(defmethod calc-pf cs-geo ( (pf c geonode-pf choice) ) 
(list (cons pfc (built-in-pfchoices pf c) ) 
pfO) 

(defmethod calc-pf cs-geo ((pfc geoname-pf choice) ) 
(list (cons pfc (built-in-pfchoices pfc)) 
pfc)) 

(defun calc-pf cs (pf choice) 

;; Use this fn for pfchoices that never vary, e.g. sort, fmt, max 
(list (built-in-pfchoices pfchoice) 
pf choice) ) 

(defun built-in-pfchoices (pfchoice) ^ 

(pickfield-choices (pickf ield-f rom-key (pf choice -pickfieldkey pfchoice)))) 

(defun erait-pickfield-menu (pickf ield-key thread pfcs selected-pf c) 
(with- thread-output (stream thread) 

(format stream "<select name='-'S»>" pickf ield-key) 
(delist (pfc pfcs) 

(format stream "<option value=~S-'A>-A" 
(pf choice-key pfc) 

(if (eql pfc selected-pfc) " SELECTED" "") 
(pf choice -name2 pfc) ) ) 
(format stream "-%</select>") ) ) 

(defun emit-pickfield-flat (pickf ield-key thread pfcs selected-pfc) 
(with-thread-output (stream thread) 

(format stream "-A:" (pickf ield-name (pickf ield-f rom-key pickf ield-key) ) ) 
(dolist (pfc pfcs) 

(format stream " <input type=' radio' name='-S» value= ' -S • ~A> -A 

&nbsp ; " 

pickf ield-key 
(pfchoice -key pfc) 

(if (eql pfc selected-pfc) " CHECKED" "") 
(pf choice -name2 pfc) ) ) ) ) 

t f t 

1 

(def parameter *breadcrumb- arrow* " > ") 

(defun breadcrumb (thread tally geo) 

(declare (special *world-geo-pf choice*) ) 
(with-thread-output (stream thread) 

;; Emit the name of the search as first breadcrumb 

(let ( (searchname (search-name -from- tally- filename (tally- filename 
tally) ) )) 
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(cgi-anchor-with-text thread searchname 'SEARCHHOME 

♦ id searchname) ) 
(princ *breadcrumb- arrow* stream) 

Emit the super-places, as links 

(breadcrumb -place thread tally (breadcrumbl geo tally) ) 

Emit current place, as plaintext (not a link) 

(format stream (pf choice-name geo) ) 

Maybe output a www address 

(let (x) 

(when (and (geonode-pf choice-p geo) 

(setq X (node-place (geonode-pf choice -node geo tally))) 
(institution-p x) 
(setq X (institution-www x) ) ) 
(formatt thread "     <a href=»-A' target=_new>- : *-A</a>' 

x) ) ) ) ) 

(defmethod breadcrumbl ( (pf c geonode-pf choice) tally) 

(place -superplace (node-place (geonode-pf choice -node pf c tally) ) ) ) 

(defmethod breadcrumbl ( (pf c geoname-pf choice) tally) 
(multiple-value-bind (places level) 

(author-leafplaces ( get- author -rec tally (pfchoice- 

name pf c) ) ) 

(if (<= level 2) 
(first places) 
nil))) 

(defmethod breadcrumbl (pfc tally) ; members of std geo menu 
(declare (ignore pfc tally) ) 
(top-place) ) 

(defun breadcrumb-place (thread tally place) 
(when place 

(breadcrumb-place thread tally (place-superplace place) ) 
(node-link thread tally (find- place -node place tally) 1) 
(formatt thread *breadcrumb- arrow*) ) ) 

(defun breadcrumb-up (thread tally place firstp) 
(unless (top-place-p place) 
(when (not firstp) 

(princt " &#183 ; " thread) ) 
(node-link thread tally (find-place-node place tally) 1) 
(breadcrumb-up thread tally (place-superplace place) nil))) 



®®file noder 

(defstruct node 
number 
place 
(score 0) 

(score? 0) ; when there is >1 leafplace for a paper 
(papers nil) 

(papers? nil) ; when there is >1 leafplace for a paper 
(subs nil) 



Page 47 of 82 



) 

(def struct (unclassified-node (: include node}) 
) 

(def struct (person-node {: include node)) 
authors core) 

/ / / ** ** " 

1 

(defun make -nodes (tally) 

(let* ((nodes (make-array 100 tadjustable t :f ill-pointer 0)) 
(top-place (place -from-place -key *world-key*) ) 
(top-node (add-a-node nodes (make-node :place top -place) )) ) 
(make-nodesx nodes top-node (place -subkeys top -pi ace ) ) 
(setf (tally-nodes tally) nodes) 
(setf (tally-topnode tally) top-node) 
(values) ) ) 

(defun add-a-node (nodes node) 

(setf (node-number node) (fill-pointer nodes)) 
(vector -push -extend node nodes) 
(values node) ) 

(defun find-place -node (place tally) 
(find place (tally-nodes tally) 

:test #• (lambda (place node) 

(and (eql place (node -pi ace node) ) 

(not (unclassif ied-node-p node) ) ) ) ) ) 

(def\in node -from-place -key (placekey tally) 

(find -place -node (place -from-place -key placekey) tally) ) 

(defun node - f rom- node- num (tally num) 
(aref (tally-nodes tally) num) ) 

(defun tally-root -node (tally) 

(node-f rom-place-key *world-key* tally) ) 

(defun make-nodesx (nodes node subplace-keys) 
(when s\ibp lace -keys 

(let* ((placel (place -f rom-place-key (first subplace-keys))) 
(nodel (add-a-node nodes (make-node iplace placel)))) 
(push nodel (node-subs node) ) 

(make-nodesx nodes nodel (pi ace -subkeys placel) ) 
(make-nodesx nodes node (rest subplace-keys))))) 

(defun node -total -score (node) 
(+ (node -score node) 
(node -score? node) ) ) 

(defun score-nodes (tally) 

;; First, assign each paper to one or more nodes. 

; ; If a paper has no place assigned (ie, no leafplaces) assign it to the 
world node. 

(let ( (nodes (tally-nodes tally) ) 
leafplaces 
p ape mode) 

(dovec (paper i (tally-paperdata tally) ) 

(setq papernode (if (setq leafplaces (paper-leafplaces paper)) 
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(find (first leaf places) nodes :key # 'node-place) 
(tally-topnode tally) ) ) 
(push paper (node-papers papemode) ) 
(incf (node-score papemode) (paper-score paper)) 
(delist (place (rest leafplaces) ) 

(setq papemode (find place nodes :key #' node -place ) ) 

(push paper (node -papers? papemode) ) 

(incf (node-score? papemode) (paper-score paper))) 

) 

; ; Now compute the scores for the node tree 
(score-nodesx nodes (tally-topnode tally))) 
(values) ) 

(defun score-nodesx (nodes node) 

(dolist (subnode (node-subs node) ) 

(score-nodesx nodes subnode) ) 
(when (and (node -subs node) 

(or (node -papers node) 

(node-papers? node)) 
(find-if #*plusp (node-sxibs node) 
(push (add-a-node nodes 

(make-unclassified-node 
:place (find-unclassified-place 



Why is this OR clause here? 



: key # ' node -total - score ) ) 



(node -place node) 
(node-place (first (node-subs node) ) ) ) 

(node -papers node) 
(node -papers? node) 
(node- score node) 
(node -score? node) 



:papers 
: papers? 
: score 
: score? 

:number (fill-pointer nodes))) 

(node-subs node) ) 
(setf (node-papers node) nil 

(node -papers? node) nil 

(node -score node) 0 

(node-score? node) 0)) 
; ; Now can do simple summations 
(incf (node-score node) (reduce #'+ 
(incf (node-score? node) (reduce #»+ 
(values) ) 



(node -subs node) 
(node-subs node) 



:key #« node-score) ) 
:key #»node-score?) ) 



(defun alpha -countries (pi p2) 

(cond ((eql (place -key pi) 'US) 
t) 

((eql (place-key p2) 'US) 
nil) 

( (string -lessp (place-name pi) (place-name p2) ) 
t) 
(t 

nil))) 



;;; (defun alpha-place (pi p2) 

(let ((diff {- (position (type-of pi) 
INSTITUTION) ) 

... (position (type-of p2) 

INSTITUTION) ) ) ) ) 

(cond ( (plusp diff) 

Pl) 

( (minusp diff) 
p2) 

( (equal (place-key pl) ' (co 
pl) 



i t 
7 t 
t t 
f f 
* 7 



(COUNTRY STAYT CITY 
(COUNTRY STAYT CITY 



US)) 
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((equal (place-key p2) ' (co . us)) 
p2) 

( (string-lessp (place-name pi) (place-name p2)) 

Pl) 
(t 

p2)))) 



®@file parse-paper 

(defstruct field 
key 
value 
) 

#1 

(defun country-name- to -abbrev (name) 

(or (second (find name '{("UNITED STATES" US) 

("ENGLAND" UK) 
("INDIA" IN) 
("NETHERLANDS" NL) 
("ITALY" IT) 
("DENMARK" DK) 
("IRELAND" IE) 
("GERMANY" DE) 
("FRANCE" FR) 
) 

:key #' first 
:test #'string=:) ) 

(progn 

{dbp 'unfound- country name) 
name) ) ) 



(let ( (fields-of -interest • (AU CY AD PMID- PT DP TI) ) ) 

(defun parse-paper (f outfile) 

;; Last author is processed first • 

(let (pmid titlelines authors piibtypes addresslines year country) 
(delist (field (extract-fields f ) ) 
{ecase (field-key field) 

(AU (push (field-value field) authors)) 
(CY (setf country (field-value field) ) ) 
(AD (push (field-value field) addresslines)) 
(PMID- (setf pmid (field-value field))) 

(push (field-value field) titlelines)) 
(push (field-value field) pubtypes) ) 

(setf year (derive -paper -date (field-value field)))) 



(TI 
(PT 
(DP 
)) 



; ; Write the paper to the LXL file 

(format outfile (make -paper " ) 
(format outfile «~@{-% -S -S-}" 
:pmid pmid 

: title (format nil "-A-.{ ~A~}" (first titlelines) (rest 

titlelines) ) 

-.authornames (cons «LIST (reverse authors)) 
ilastauthor (first authors) ; is actually last author 
lauthorcount (length authors) 
:pt (cons 'LIST pubtypes) 
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: address (format nil "-A-{ -A-}« (first addresslines) (rest 

addresslines) ) 

:year (or year 0) 

: country country 
) 

{ format out file ") «) 
(values) ) ) 

(defun extract-fields (f) 
(let ((fieldrecs nil)) 

( catch * paper-has -ended 
(loop 

(if (paper-has -ended-p * line -buffer*) 
(throw 'paper-has-ended t) 

(let ((fieldkey ( read- from- string *line -buff er*) ) ) 
(if (member fieldkey fields-of -interest) 

(push (make-field :key fieldkey rvalue (get-field-value 

f)) 

fieldrecs) 
(read-until-next-f ield-start f ) ) ) ) ) ) 

; (dbp 'field-recs= fieldrecs) 

(values fieldrecs) ) ) ) 

(defxin derive -paper-date (yr+mo) 

;; < yr+mo > is the value of the Medline DP field. Format: "1993 J-un" 
;; This is changed to a floating point number, eg: 1993.06 
;; If we cannot discover a date, it's set to 0000. 
(multiple -value -bind (yr restart) 

(read- from- string yr+mo) 
(unless (numberp yr) 

(tmless (numberp (setq yr (read- from- string yr+mo nil nil 

:end (min 4 (length 

yr+mo) ) ) ) ) 

(setq yr 0000) ) ) 
(let ((mo (position (read- from- string yr+mo nil nil 

: start restart 

:end (min (+ 3 restart) (length 

yr+mo) ) ) . . ^ 

» (xx jan feb mar apr may jun 3ul aug sep oct nov 

dec)))). 

{when mo 

(incf yr (float (/ mo 100)))) 
(values yr) ) ) ) 

(defun get-field-value (f ) 

(let ((vals (list (subseq *line-buf f er* 6)))) 
(catch 'next -field 
(loop 

(read-a-line f) 

(when (plusp (length *line-buf fer*) ) 

(if (char= (aref *line-buf f er* 0) #\Space) 

(push (sTibseq * line -buffer* 5) vals) ; 5 leaves leading space 
(throw 'next-field t) ) ) ) ) 
; (dbp (format nil "-.{-A-}" (reverse vals))) 
(values (format nil "-{«A-}" (reverse vals))))) 

(defun read-until-next-f ield-start (f) 
(catch 'next-field 
(loop 

(read-a-line f) 

(and (plusp (length *line-buf f er*) ) 
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(not (char= (aref *line-buf f er* 0) #\Space) ) 
(throw 'next-field t) ) ) ) ) 

(defun pape r- has- ended -p (line) 

(search "</pre>" line :test char-equal) ) 

(defun find-paper-start (f) 

;; When it returns, *line-buf f er* is the first AU line. 
;; Ends up losing the UI line that precedes the first AU, 
; ; but we don ' t care , 
(let ( (prevline "")) 

(catch * found-paper- start ++ 
(loop 

(read-a-line f) ; might throw 'end-of-file 

(if (and (> (or (mismatch *line-buf f er* "AU - " :test #'char=) 
-1) 

5) 

(search «<pre>" prevline :test #» char- equal ) ) 
(throw «found-paper-start++ 't) 
(setq prevline *line-buf fer*) ) ) 
(values) > ) ) 

(let ( (eof (gensym) ) ) 

(defun read-a-line (f ) 

(setq *line-buffer* (read-line f nil eof)) 
(if (eql eof * line -buffer*) 
(throw »end-of-file t) 
*line-buffer*))) 



®®file pickfield 

(def struct pickfield 
name 
key 

choices 
) 

(def struct pfchoice 
pickf ieldkey 
selectedp 
key 
name 
name 2 
filter 
) 

(def struct (geonode -pfchoice (: include pfchoice))) 
(def struct (geoname -pfchoice ( : include pfchoice) ) ) 

(defmacro make-a-pickf ield (name key choice-specs) 
" (make-pickf ield -.name ,name 
• :key /key 
: choices , choice -specs) ) 

(defmacro make -a -pfchoice (pickf ield-key selectedp key name flatname filter) 
" (make -pfchoice :pickf ieldkey (quote , pickf ield-key) 
: selectedp , selectedp 
:key (quote ,key) 

: name , name 

:name2 (or , flatname ,name) 
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: filter , filter)) ; in case we need place for extra 

data 



#1 

(defun usa/canada-p (p) 

(or (place-placekey= p *place-usa*) 

{place-placekey= p *place-canada*) ) ) 

i# 

(defvar *world-geo-pf choice*) 
(defvar *paper-wtc-pf choice*) 

(defparameter *pickfields* 

; ; Cannot make the assumption that a pf choice will always be a member of 
;; pickfield choices! (search-all -files on this comment to see why) 

(list 

(make-a-pickf ield ; Choices must be in ascending order for < wts-llevel- 
down > 

"What to show" 
' wts 

;; Must be synchronized with < defmethod place -pf choice -key > 
(list (setg 



*paper-wtc-pf choice* 



) 

; Stub 



(make - a -pf choice 


wts 


nil 


ap 


"Papers " 


nil ' PAPER- P 


(make-a-pf choice 


wts 


nil 


ep 


"People" 


nil #' FALSE 


(make-a-pf choice 


wts 


t 


ni 


"Institutions " 


nil #' institution -p 


(make - a -pf choi ce 


wts 


nil 


ic 


"Cities" 


nil #'city-p 


(make - a -pf choice 


wts 


nil 


ts 


"States/Provinces " 


nil #'stayt-p 


(make-a-pf choice 


wts 


nil 


oc 


"Countries" 


nil #• country -p 



))) 

(make-a-pickf ield 
"Geography" 
'geo 

(list (setq 

*world-geo-pf choice* 

(make-a-pf choice gee nil w "The world" "in the world" 

#»true) ) 

(make-a-pf choice geo nil u "USA/ Canada" "in USA/ Canada" 

(lambda (p) 

(or {place2-is-or-isin-placel *place-usa* p) 
(place2-is-or-isin-placel *place- Canada* 

p)))) 

(make-a-pf choice geo nil b "Britain/Ireland" "in Britain/Ireland" 
#' (lambda (p) 

(or (place2-is-or-isin-placel *place-uk* p) 
(place2 -is -or-isin-placel *place-ireland* 

p)))) 

(make-a-pf choice geo t e "US/Canada/Britain/ Ireland" "in 
US/UK/ Can -/Ire." 
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p) 



p)))) 



(make -a-pf choice 



p)))))) 

(make - a -p 1 ckf i e Id 
"Sort by" 
'srt 

(list (make-a-pf choice 
score" 



#» (lambda (p) 

(or (place2-is-or-isin-placel *place-usa* p) 
(place2-is-or-isin-placel *place-canada* 

(place2-is-or-isin-placel *place-uk* p) 
(place2-is-or-isin-placel *place- Ireland* 

geo nil o "Outside the USA" "outside USA" 
#• (lambda (p) 

(not (place2-is-or-isin~placel *place-usa* 



srt t s "Score" 



'sorted by 



nodel) ) 
node2) ) ) ) 



distance" 



#• (lanibda (nodel node2) 

(cond ( (egl (type-of nodel) (type-of node2)) 
{> (node -total -score nodel) 
(node -total -score node2) ) ) 
( (unclassif ied~node-p node2) 
t) 

(t nil)))) 

(make-a-pfchoice srt nil n "Name" "sorted by name" 

#' (lambda (nodel node2) 

(cond ( (eql (type-of nodel) (type-of node2)) 
(string-lessp (place-name (node-place 

(place-name (node -place 

( (unclassif ied-node-p node2) 
t) 

(t nil)))) 

(make-a-pf choice srt nil d "ZIPcode" "sorted by ZIPcode" 
#» (lambda (nodel node2) 

(> (length (node-subs nodel)) 
(length (node-subs node2))))) 
(make-a-pf choice srt nil d "Distance from ZIPcode" "sorted by 

#« (lambda (nodel node2) 

(> {length (node-subs nodel) ) 

(length (node- subs node2))))))) 



(make-a-pickf ield 
"Max per page" 
'max 

(list (make-a-pf choice 
(make-a-pf choice 
(make-a-pf choice 
(make-a-pf choice 

kludge 



max nil 10 

max t 30 

max nil 100 

max nil all 



"10" "show 10 max" 10) 

"30" "show 30 max" 30) 

"100" "show 100 max" 100) 

"All" "show all" 999999))) 



(make-a-pickf ield 
"Output format" 
'fmt 

(list (make-a-pf choice fmt nil si "Sublist" 
(make-a-pf choice fmt t sp "Sublist+" 
(make-a-pfchoice fmt nil tr "Tree" 
(make -a-pf choice fmt nil db "Debug" 



"List" 
"List-!-" 
"Tree" 
" *debug* " 



• spn-sublist ) 
* spn-sublist+) 
' spn-s\abtree) 
' spn-papers+) 
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; (make-a-pfchoice fmt nil pa "Papers" "Papers" 'spn-papers) 
)) 

)) 

(defun pickfield-from-key (pickf ield-key) 

(find pickf ield-key *pickfields* :key # 'pickf ield-key) ) 

(defun get-pickfield-choice (pickf ield-key pf choice-key) 
;; NIL is an occasional, and useful, return value. 
;; (e.g. when use menus to say I want to list all institutions in 
California) 

(find pfchoice-key 

(pickf ield-choices 

(find pickf ield-key *pickfields* :key # 'pickf ield-key) ) 
:key #' pfchoice-key) ) 

(defparameter *window-root -node -key* 'rw) 

(assert (null (get-pickfield-choice »GEO *window- root -node -key* ) ) nil 

"Cannot give *window-root-node-k€y* a keyvalue used by another GEO 
pf choice . " ) 

(defun default-pfchoice (pickf ield-key) 

(find-if #'pfchoice-selectedp (pickf ield-choices (pickfield-from-key 
pickf ield-key) ) ) ) 

#1 

(defun wts-downlevel (wts-pf choice nlevels) 
(let* ( (pfchoices (pickf ield-choices 

(pickfield-from-key 
(pfchoice-pickf ieldkey wts-pf choice) ) ) ) 
(pos (- (position wts-pfchoice pfchoices) nlevels))) 
(nth pos pfchoices))) 

1# 

(defun wts-rightlevel (node) 
(if (node-subs node) 

(place-pf choice -key (node-place (first (node-subs node) )) ) 
(etypecase (node -place node) 
(PLANET *OC) 
(COUNTRY »ts) 
(STAYT 'ic) 
(CITY 'ni) 
(INSTITUTION »ep) 
(PEOPLE »ap)))) 

(defun fmt -shows -papers -p (tally) 

(eql (pfchoice-key (tally-fmt tally)) 
•PA) ) 

(defun fmt-shows-debug-p (tally) 

(eql (pfchoice-key (tally-fmt tally) ) 
*DB)) 

(defun wts-is-people-p (tally) 

(eql (pfchoice-key (tally-wts tally)) 
*EP) ) 

(defun wts-is-papers-p (tally) 

(eql (pfchoice-key (tally-wts tally)) 
•AP)) 
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®®file places -find 

(defun locate (address) 
(let {(places nil)) 

(multiple-value-bind (tokens email-domains email -address) 
(tokenize-address (string-upcase address)) 
(setq places (try-domain-rules places email -domains ) ) 
(dotimes (i (fill-pointer tokens)) 

(setq places (try-nont Id- rules places tokens i (string-right-trim 
" , . " (aref tokens i) ) ) ) ) 

(dotimes (i (fill-pointer tokens) ) 

(setq places (try-help -rules places tokens i (string-right- trim 
" , . " (aref tokens i) ) ) ) ) 

(values places emai 1 -address) )) ) 

(defun try-domain-niles (places test-domains) 
(when test -domains 

(dolist (rule (gethash (first test-domains) *geo-tokens* nil)) 
(when (domain-rule-p rule) 

(let* ( (rule-domains (rule-parmdata rule) ) 

(diff (mismatch test-domains rule-domains :test #'string=))) 
(setq places 

(maybe -add-place places rule (or (null diff) 

(>- diff (length rule- 
domains) ))))))) ) 
(values places) ) 

(defun try-nontld-rules (places tokens i token) 
(dolist (rule (gethash token *geo-tokens* nil) ) 

(unless (member (rule-id rule) places :key #« rule-id :test #'=) 
(setq places 

(maybe -add -place places rule 

(case (rule-method rule) ; return rule if anile 

successful 

(:one t) 

(:adj ( the- ad j -test i tokens (rule-paarmdata 

rule) ) ) 

(:all (the-all-test i tokens (rule-parmdata 

rule) ) ) 

(t nil)))))) 

(values places) ) 

(defun the-adj-test (address-i address -tokens rule-tokens) 
; ; returns T or NIL 
(when (<= 

(+ address-i (length rule - tokens ) ) 
(length addres s- tokens ) ) 
(let ( (ii address-i) 
(matchp t) ) 
(dolist (rule-token rule-tokens) 

(if (string-equal rule-token (aref address -tokens ii) ) 
(incf ii) 

(return (setq matchp nil)))) 
(values matchp) ) ) ) 

(defun the-all-test (address-i address -tokens rule-tokens) 
; ; returns T or NIL 
(let ((ii address-i) 
(okp t)) 

(dolist (rule-token rule-tokens) 
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(setq ii (position rule-token address -tokens : start ii :test 
# * string-equal) ) 

{when (null ii) 
(setq okp nil) 
(return) ) ) 
(values okp) ) ) 

(defun the-help-test (successful-rules where-type where-key) 

; Note that CLtL2 page 391 guarantees that the calls have the form: 
; (funcall # 'placel-is-or-isin-place2 item (keyfn sequence - item) ) 
(dbp (place-key (place-f rom-2step where-type where-key) ) 

(mapcar # 'place-key (mapcar #» rule-place successful-rules))) 
(delist (r successful-rules) 
(princ " ") 

(princ (if (place2-is-or-isin-placel 

(place-from-2step where-type where-key) 
(rule-place r) ) t nil))) 
(find (place-from-2step where-type where-key) 
successful -rules 
:key #' rule-place 

:test #»place2-is-or-isin-placel) ) 

(defun try-help-3niles (places address -tokens address-i address -token) 
; ; These rules use only the known facts , not suspected values . 
(let ( (places2 (remove- if -not #• certainty-rule -p places) ) ) 
(delist (rule (gethash address-token *geo-tokens* nil)) 
(when (and (help-rule-p rule) 

(not (member (rule -id rule) places :key #• rule -id :test 

#•=)) 

(the-adj -test (1+ address-i) address -tokens (rest (first 
(rule-parmdata rule) ) ) ) ) 

(let* ( (rule-parms (rule-parmdata rule) ) 

(successp (try-help-rules -clauses places2 

(second rule-parms) 

(if (numberp (third irule- 

parms) ) 

(fourth rule-parms) 
(list (third rule-parms) 

(fourth rule-parms) ) ) ) ) ) 

(setq places (maybe -add -pi ace places rule successp)) 
(when successp 

(push rule places2) ) ) ) ) ) 
(values places) ) 

(defun try-help-rules -clauses (places boolean-op wherespecs) 
(if (null wherespecs) 
(ecase boolean- op 

(-AND- t) ; AND all -- goes until finds a false 
(-NOT- t) ; NOT any -- goes until finds a true, returns false 
(-OR- nil)); OR any -- goes until finds a true, returns true 
(let ((clause-result (the-help-test places (first wherespecs) (second 
wherespecs) ) ) ) 

(ecase boolean-op 

(-AND- (if clause-result 

(try-help-rules-clauses places boolean-op (cddr 



wherespecs) ) 



wherespecs) ) ) ) 



(values nil) ) ) 
(-NOT- (if clause-result 
(values nil) 

(try-help-rules -clauses places boolean-op (cddr 
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(-OR- (if clause-result 
(values t) 

{try-help-rules -clauses places boolean-op (cddr 

wherespecs) ))))))) 

(defun maybe-add-place (places rule addp) 
(if addp 

(cons rule places) 
places) ) 



1 

(defun tokenize -address (address) 
; ; breaks tokens at white space . 

;; dots are separate token if they are on trailing edge of other token, 
(let ((tokens (make-array 25 :adjustable t :f ill-pointer 0)) 

(token-in-progress (make-array 25 .-adjustable t :f ill-pointer 0) ) 

(last-char #\Space) 

c) 

(f let ( (whitespace-p (chr) 

(char= #\Space chr) ) 

( add- to- token -in-progress (chr) 
(vector-push-extend chr token-in-progress) ) 

(end-of -token () 
(when (plusp (fill-pointer token-in-progress) ) 

(vector-push-extend (coerce token-in-progress 'string) 

tokens) 

(setf (fill-pointer token-in-progress) 0)))) 
(dotimes (i (length address) ) 

(cond ( (char= (setq c (aref address i) ) #\Space) 
(unless (whitespace-p last-char) 
(end-of -token) ) ) 
((find c :test #'char=) 

(if (or (whitespace-p last-char) 

(and {< (1+ i) (length address)) 

(not (whitespace-p (aref address (1+ i) ) ) ) ) ) 
(add- to -token -in -progress c) 
(progn 

(end-of-token) 

(add-to-token-in-progress c) 
(end-of -token) ) ) ) 
((char= c #\/) 

(end-of -token) ) 
(t (add-to-token-in-progress c) ) ) 
(setq last-char c) ) 
(unless (whitespace-p last-char) 
(end-of -token) ) 

;; Treat email addresses specially 

7 7 

(let ((last-token (vector-pop tokens)) 
(trailing-period-p nil) ) 
(when (and (strings last-token ".") 

(plusp (fill-pointer tokens) ) ) 
(setq trailing-period-p t) 
(setq last-token (vector-pop tokens))) 
(multiple-value-bind (domains email) 

(tokenize-email last- token) 
(when (null domains) 

(vector-push last-token tokens) 
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;; Preserve trailing period because "USA." needs it, for 

example . 

(when trailing-period-p 

(vector-push " , " tokens) ) ) 
(values tokens domains email) ) ) ) ) ) 

(defun tokenize-email (email) 

;; Returns the domain as a backwards list (e.g. (edu Stanford)) and the 
/; complete email address 

;; Would be nice to split at @ sign, then split second half at dots, 
(let ((start (position #\@ email :test #'char=))) 
(when start 

(values (tokenize-email-domain (1+ start) email) 
email) ) ) ) 

(defun tokenize-email -domain (start email) 

;; Domains are returned in reverse order, eg: (edu Stanford cs) 
(let ( (domains nil) ) 
(do ( (right 

(position #\. email :test #'char= : start start) 
(position #\. email :test #»char=: :start start))) 
((null right) 
(push (subseg email start) domains)) 
(push (subseq email start right) domains) 
(setq start (1+ right))) 
(values domains) ) ) 



®@file places 

(defstruct place 
name 

; not used except for debugging help 
number ^ ^ sf 

subkeys 

) 

(defstinict (planet (: include place) ) 
) 

(defstruct (subordinate -place (: include place)) 
isin-key 
) 

(defstruct (abbreviated-place {: include subordinate -place ) ) 
abbrev 
) 

(defstruct (country (: include abbreviated-place)) 
(defstruct (stayt (: include abbreviated-place)) 



(defstruct (unabbreviated-place (: include subordinate -place ) ) 
(defstruct (region (: include unabbreviated-place)) 
(defstruct (city (: include unabbreviated-place) ) 
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) 



(def struct (institution (: include unabbreviated-place) ) 
www 
wwwdir 

(ispartof nil) 
) 



(def parameter *world-key* "pl#earth") 



(defvar *place-canada*) ; set when rules read in and processed 

(defvar *place-ireland*) 

(defvar *place~uk*) 

(defvar *place-usa*) 



;; Must be synchronized with *pickfields* 

(def method place~pf choice-key ( (p country)) 'oc) 

(defmethod place-pf choice-key ( (p stayt) ) 'ts) 

(defmethod place-pf choice-key ( (p city)) 'ic) 

(defmethod place -pf choice -key ( (p institution)) 'ni) 

(defmethod place -key-from- 2 step (class -abbrev place-abbrev) 

(error "Illegal class or place abbreviation: -S -S" class-abbrev place- 
abbrev) ) 



(defmethod place-key-from-2 step ((class-abbrev (eql 

(format nil "co#~(~A~)" place-abbrev)) 
(defmethod place-key-f rom-2step ((class-abbrev (eql 

(foannat nil "st#-(-A-)" place-abbrev)) 
(defmethod place -key- from- 2 step ((class-abbrev (eql 

{ string- downcase name) ) 
(defmethod place -key-from- 2 step ( (class-abbrev (eql 

(string -downcase name) ) 
(defmethod place -key-from-2 step ((class-abbrev (eql 

(format nil "un#- (-A-) " key)) 

(defun placekey=s (kl k2) 
(string-equal kl k2)) 



• CO) ) place-abbrev) 
' St ) ) place-abbrev) 



■ci)) name) 



' in) ) name) 



'un)) key) 



(defvar *places*) 
(defvar *place-keys*) 
(defvar *world-key*) 

(defun prepare -to -load -pi aces () 

;; Called just before places are first loaded, 

(setf *places* (make-array 1000 : adjustable t : fill-pointer 0 : element- type 
* place) ) 

(setf *place-keys* (make -hash- table :test #'equal isize 2000)) 
(values) ) 



(defun place -number -from-place -key (place -key &key must-find-p) 
(or (gethash place -key *place-keys* nil) 
(if must-find-p 

(error "Unable to find place key: -S" place -key) 
nil))) 



(defun place-f rom-place-key (place-key &key must-find-p) 

(let ( (place -number (place-number- f rom-place-key place-key :must-find-p 
must-find-p) ) ) 

(when place -number 

(place-f rom-place-number place -number) ) ) ) 
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(defiin place -from-place -number- (place -number) 
(aref *places* place -number) ) 

(defun place -from-2 step (class-abbrev place-cibbrev) 

(place -from-place-key (place-key-f rom-2step class-abbrev place -abbrev) ) ) 

(defmethod placel-is-or-isin-place2 (pi p2) 
(declare (ignore pi p2)) 
(values t) ) 

(defmethod placel-is-or-isin-place2 ( (pi subordinate -place) p2) 
(or (eql pi p2) 

(placel-is-or-isin-place2 (place -superplace pi) p2))) 

(defmethod place2-is-or-isin-placel (pi p2) 
(eql pi p2) ) 

(defmethod place2-is-or-isin-placel (pi (p2 subordinate -place ) ) 
(or (eql pi p2) 

(place2-is-or-isin-placel pi (place -superplace p2) ) ) ) 

(defun conf irm-place-key (place -key) 

(assert (place -number- from-place -key place-key :must-find-p t) nil 

"Undefined place key: -S" place-key) 
(values place -key) ) 

(defmethod place- superplace (place) 
(declare (ignore place) ) 
nil) 

(defmethod place -superplace ( (place subordinate -pi ace) ) 

(place -from -place-key (siibordinate-place-isin-key place) :must-f ind-p t) ) 

(defun place -placekey= (place placekey) 
{placekey= (place -key place) placekey) ) 

(defun top-place-p (place) 
; ; There can be only one . 
(plan.et-p place) ) 

(defun top -place () 

(place -from-place -key *world-key*) ) 

(defun initial ize-place (name rules isin-key place -creat ion- fn &rest 
creation-argsO) 

;; Called in two ways: (1) when initial place db read in, (2) dynamically, 
when 

; ; we create "unclassified" places . Only in case 1 will there be 
invisibles, 

;; Unless it*s going to be invisible, we create a new object and return it, 
(declare (dynamic -extent creat ion-args) ) 
(if (member : invisible rules) 
(progn 

(when (intersection *(:dxl :dx2 : placekey- var) rules) 
(assert (not (find : placekey -var rules) ) nil 

"Cannot use : PLACEKEY -VAR in invisible rule ~S ~S" creation- 

argsO rules) 

(assert name nil 

"Cannot use :DX1 or :DX2 in invisible rule -S -S" creation- 

argsO rules) ) 
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(f ill-in-place-rules 
(place-f rom-place-key isin-key) 

(cond ((member :dxl rules) (list* :dx name (delete :dxl rules))) 

((member :dx2 rules) (list* :dx-adj name (delete :dx2 rules))) 
(t rules))) 

(values) ) 

(let* ( (creation-args (if isin~key 

(list* :isin-key isin-key creation-argsO) 
creation-argsO) ) 
(place (apply place-creation-f n creation-args) ) 
(key (getf creation-args :key) ) 
(number (fill-pointer *places*) ) ) 
(assert (null (gethash key *place-keys* nil) ) nil 

"Non-unique key for place -S" key place) 
; (setf (place-key place) key) 
(setf (place-number place) number) 
(vector-push--extend place *places*) 
(setf (gethash key *place-keys*) number) 
(fill-in-place-rules place rules) 
(initialize-place-subkeys place) 
(values place) ) ) ) 

(def method initialize-place-subkeys { (place subordinate -place) ) 

Pushnew used only to make things simpler in development environment, 
(In case, for example, we redefine cities only.) 
In production environment, could use Push, 
(pushnew (place-key place) (place -subkeys (place-superplace place)) :test 
#• strings) ) 

(defmethod initialize-place-subkeys (place) 
(declare (ignore place) ) ) 

/ / / ~ — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — — ' " 

1 

(defun make-a-planet () 
(initialize-place nil 
nil 
nil 

#' make -planet 
:name "The World" 
skey *world-key*) ) 

(defun make -a -country (spec) 

(let ( (abbrev (first spec) ) ; a symbol 

(name (second spec) ) 
(rules (cddr spec) ) ) 
(initialize-place name 

(list* :tld abbrev rules) ; country abbrev = www top 

level domain 

*world-key* 

# ' make - count ry 

:key (place-key-f rom-2step *co abbrev) 
: abbrev (symbol -name abbrev) 
: name name ) ) 

(values) ) 

(defun make-a-state (spec) 

(let ((abbrev (symbol-name (first spec))) 

(country -abbrev (symbol -name (second spec) ) ) 
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(name (third spec) ) 

(rules (cdddr spec) ) ) 

(initialize-place name 
rules 

(conf irm-place-key (place -key- from- 2 step 'co coimtry- 

abbrev) ) 

#*make-stayt 

:key (place-key-f rom-2step ' st abbrev) 
:abbrev abbrev 
:name name) ) 

(values) ) 



(defun make -a -city (spec) 

(let ( (2step-class (first spec)) ; a symbol' 
(isin-abbrev (second spec) ) 
(name (third spec) ) 

(rules (cdddr spec))) 

(assert (member 2step-class ' (re st co) ) nil 

"City ~S must be in a region, state, or country, not ~S" 
name 2step-class) 
(initialize-place name 
rules 

(conf irm-place-key (place -key-from-2 step 2 step -class 

isin-abbrev) ) 

#• make-city 

:key (place-key-f rom-2step *ci name) 

:name name) ) 

(values) ) 

(defun make -an- institution (specs) 
(let ((name (first specs)) 

(2step-class (second specs) ) 
(is in (third specs) ) 

(rules (cdddr specs))) 

(if (member : invisible rules) 

(assert (eq 2step-class 'co) nil 

"Invisible institution -S must be in a country, not -S" name 

2step-class) 

(assert (eq 2step-class »ci) nil 

"Institution -S must be in a city, not «S" name 2step-class) ) 
(initialize-place name 
rules 

(conf irm-place-key (place-key-f rom-2 step 2step-class 

isin) ) 

#» make-institution 

:key (place-key-f rom-2 step 'in name) 

:name name) ) 

(values) ) 

(defun make-an-invisible-institution (specs) 
(let ( (2step-class (first specs) ) 
(isin (second specs}) 

(rules • (cddr specs) ) ) 
(make -an- institution (list* "X" 2step-class isin : invisible rules)))) 

(defmethod ins ti tut ion2- is -part -of -institution! (il i2) 
(declare (ignore il i2) ) 
(values nil) ) 

(defmethod institution2-is-part-of -institutionl ( (il institution) (i2 
institution) ) 
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(find (place-key il) (institution-ispartof i2) :test #«placekey=) ) 



tit — — — — — — — — — 

1 

(defun find-unclassified-place (place subplace) 

(let ((key (place -key- from-2 step 'un (place-key place) )) ) 
(or (place-from-place-key key) 

(make -unclassified-place sxibplace place key)))) 

(def method make-unclassified-place ( (subplace country) place key) 
(make-unclassified place # 'make -country :key key labbrev key)) 

(defmethod make-unclassified-place ((subplace stayt) place key) 
(make-unclassified place #'make-stayt :key key :abbrev key)) 

(defmethod make-unclassified-place ((subplace city) place key) 
(make-unclassified place #'make-city :key key)) 

(defmethod make -unclassified-place ( (subplace institution) place key) 
(make-imclassif ied place # 'make- institute on :key key)) 

(deftin make -unclassified (place creation-fn &rest creation-args) 
(let ( (name (format nil "unclassif iable -A" (place-name place) ) ) ) 
(assert (getf creation-args :key) nil) ; for debugging only 
(apply #» initialize-place 

name nil (place -key place) 

creation-fn :name name creation-args))) 



@®file platform 

(defxin op en -text -window () 
(values 

#-mGl (open-stream ' text -edit -window * lisp -main -window* :output) 
#+mcl (fred))) 



©©file query04.htm 

<html> 
<head> 
<script> 

function do_submit() { 
var f rml = document . forms [ " inputs " ] ; 

var search = • »« ' + f rml. elements ["term"] • value + // [All Fields]) 

search += • AND ( "human" [Me SH Terms])'; 

search += • AND (1990 :2000 [PDAT] ) • ; 

search += • NOT (LETTER [PT] ) ^• 

search += f rml .elements ["language"] , value 

search += f rml, elements ["agegroup"] .value 

// 

var f rm2 - document . forms [ "marshall " ] ; 
frm2 .elements ["terra"] .value = search; 

frm2 .elements ["dispmax"] .value = f rml . elements ["maixdisp"] -value; 
//alert ( search ) ; 
f rTii2 . submit ( ) ; 

} 

</ scrip t> 

</head> 

<body> 
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<f orm name= "marshall " act ion= "http : //www, ncbi . nlm • nih . gov/entrez/cjuery . f cgi " 

< input type = "hidden" name="cmd" value=" search "> 

<input type="hidden" name=s"db" value="PiibMed"> 

<input type="hidden" name="doptcnidl" value= "MEDLINE "> 

<input type= "hidden" name«"term"> 

<input types "hidden" name="dispmax"> 

</f orm> 

<fonn names "inputs" act ion=" javascript :do__submit () "> 

<table border="0"> 

<tr> 

<td>Search for:</td> 

<td>< input type="typein" name="term" size="30" valuer "rash" ></td> 

</tr> 

<tr> 

<td>Dispmax : </td> 

<td><input type="typein" name="maxdisp" size="5" value="100 "></td> 

</tr> 

<tr> 

< td>Languages < / 1 d> 
<td><select name-" language "> 
<option value=""> All 

<option value=" AND eng [LA] " selected> English 

<option values" AND fre[LA]"> French 

<option values" AND ger[LA]"> German 

<option values" AND ita[LA3"> Italian 

<option values" AND jpn[LA]"> Japanese 

<option values" AND rus[LA]"> Russian 

<option values" AND spa[LA]"> Spanish 

<option values" NOT eng[IiA]"> All Non-English 

</ select ></td> 

</tr> 

<tr> 

<td>Age Groups : </td> 

<td>< select names »»agegroup"> 

<option values"" selected> All 

<option values" AND infant, newborn [MH] "> Infant, Newborn (0 to 1 month) 

<option values" AND infant [MH:NOEXP] "> Infant (1 to 23 months) 

<option value=" AND child, preschool [MH] "> Child, Preschool (2 to 5 years) 

<option value=" AND child [MH:NOEXP3 "> Child (6 to 12 years) 

<option values" AND adolescence [MH] "> Adolescence (13 to 18 years) 

<option values" AND child [MH] "> All Child (0 to 18 years) 

<option values" AND adult [MH:NOEXP] "> Adult (19 to 44 years) 

<option values" AND middle age [MH] "> Middle Age (45 to 64 years) 

<option values" AND aged [MH] "> Aged (65+ years) 

<option values" AND aged, 80 and over[MH]"> Aged 80 (80+ years) 

<option values" AND adult [MH] "> All Adult (19+ years) 

</ select ></td> 

</tr> 

<tr> 

<td colspans"2" aligns" center ">< input type=" submit "><br>< input types"button" 

value="Sbmt (NN) " onclicks "do_submit () "></td> 

</tr> 

</table> 

</form> 

</body> 

</html> 



@@file resultify.htm 
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<html> 
<head> 

<title>Web of Hope</title> 

</head> 

<body> 

<f orm act ions "http : //lo .1.0 . 4/cgi-bin/l . cgi"> 

<input type="hidden" naine=:"fn" value="read_and_report_search"> 

<table> 
<tr> 

<td><b>Filename : </b></td> 

<td><input type="typein" name=" filename" value="brocc .html"></td> 

</tr> 

<tr> 

<td valign="top"><b>Format : </b></td> 
<td valign="top"> 

<input type="radio" name- "format" value- "geo_alpha" CHECKED >Geographical - 

alphabetical 

<br> 

<input tYpe="radio" name="format" value="geo__score">Geographical - by score 
<br> 

< input type=" radio" name="f ormat " value="byauthor" >By author 
<br> 

<input type= "radio" name="f omnat" valuer "bypaper">By paper 

</td> 

</tr> 

<tr><td>  </td></tr> 
<tr> 

<td colspan=:"2" align=" center "xinput type=" submit "></td> 

</tr> 

</table> 

</f 03rm> 
</body> 
</htral> 



@@file rules 

(defvar *geo- tokens*) 
(defvar * rule -count*) 
(defvar *tlds*) 

(defstruct rule 

id strength method parmdata placekey placenura) 

(defun rule-place (mle) 

(place -from-place -number ( rule -p lac enum rule))) 

(defun prepare-to-load-rules () 
(setf *rule-count* 0) 

(setf *geo-tokens* (make -hash- table rsize 2000 :test #' equal)) 
(setf *tlds* (make-array 200 :adjustable t : fill-pointer 0)) 
(values) ) 



(defun add- rule (strength method place parm/s) 
(let ((rule (make-rule 

:id (incf * rule -count*) 
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: strength strength 
: method method 

:placekey (place-key place) ; for debugging. Should not be 

used. 

tplacenum (place-number place) 
:pa3rmdata parm/s) ) ) 
(case method 

{(rail :adj rdomayn) (add-rulel rule (first parm/s))) 
(:one (add-rulel rule parm/s)) 

(:helpz (add-rulel rule (caar parm/s))) 

(t (error "Unknown method in rule: ~S -S -S -S" 

method strength (place -key place) 

parm/s) ) ) ) ) 

(defun add-rulel (rule tokens tring) 
(assert (stringp tokenstring) nil 

"Token -S is not a string in rule -S" tokenstring rule) 
(push rule (gethash (string-upcase tokenstring) *geo- tokens*) ) ) 

(defun certainty- rule -p (rule) 
(eql :dx (rule -strength rule))) 

(defun domain-rule~p (rule) 

(eql idomayn (rule-method rule))) 

(defvm help-rule-p (rule) 

(eql :helpz (rule-method rule))) 

(defun certainrule-place (rule) 
"Returns the place or the world." 
(if (certainty-rule-p rule) 
(rule-place rule) 

(place-from-place-key *world-key*) ) ) 

(defun fill-in-place-rules (place spec) 
(when spec 

(let* ((rule-key (first spec)) 
(parms (rest spec) ) 
(pairml (first parms) ) ) 
(fill- in-place -rules 
place 

(ecase rule-key 

(:dxl (add-rule :dx 

parms) 

{:dx (add-rule :dx 

(rest parms) ) 
(:zip (add-rule :dx 

(rest parms) ) 
(:sus (add-rule :sus 

(rest parms) ) 
(:dx2 (add-rule :dx 

(place-name place)) 'list)) 
' parms) 
(:sus-adj (add-rule :sus 

♦list) ) 

(rest parms) ) 
(:dx-all (add-rule :dx 

•list) ) 

(rest parms) ) 
(:dx-adj (add-rule :dx 

•list) ) 



:one place (place-name place)) 
:one place parml) 
:one place parml) 
:one place parml) 

:adj place (coerce (tokenize- address 

:adj place (coerce (tokenize -address parml) 

:all place (coerce (tokenize-address parml) 

:adj place (coerce (tokenize-address parml) 
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(rest parms) ) 

(:dx-helpx (add-rule :dx :helpz place (list 

(coerce (tokenize -address 

parml) 'list) 

(second parms) 
(third parms) 
(fourth parms) ) ) 

(cddddr parms) ) 
(:sus-helpx (add-rule :sus rhelpz place (list 

( coer c e ( t okeni z e - addr e s s 

parml) *list) 

(second parms) 
(third parms) 
(fourth parms) ) ) 

(cddddr parms) ) 

; ; For countries only 
t } 

(:dxlc (add-rule :dx :adj place (list (place-name place) 

".")) 

pairms) 

(:dx-island (add-rule :dx :adj place (append 

(coerce ( tokeni ze - addr e s s 

parml) *list) 

(list "ISLAND"))) 

(rest painns) ) 

(:dx-islands (let ((tokens (coerce (tokenize -address parml) *list))) 
(add-rule :dx tall place (append tokens (list 



"ISLANDS") ) ) 
"ISLAND") ) ) ) 



(add-rule :dx :all place (append tokens (list 



(rest parms) ) 

(:tld (let ( (tld-string (string-upcase (symbol -name parml)))) 

(add-rule :dx idomayn place (list tld-string)) 
(assert (not (find tld-string *tlds* :test 



#'string=:)) nil 
string) . 



"Duplicate top-level domain -S" tld- 

( vector-push- extend tld-string *tlds*) ) 
(rest parms) ) 



;; For institutions only. These are not rules! 

{:domain (add-rule :dx :domayn place (tokenize -email -domain 

0 (string-upcase parml) ) ) 

(when (institution-p place) 

(setf (institution-www place) (format nil 

"http : //www. -A" parml) ) ) 

(rest parms) ) 

(:edu-domain (add-rule :dx :domayn place (list "EDU" (string-upcase 

parml) ) ) 

(setf (institution -www place) (format nil 
"http://www.-A.edu" parml)) 

(rest parms) ) 
(:www (setf (institution-www place) parml) 

(rest parms) ) 

( :wwwdir (setf (institution-wwwdir place) parml) 

(rest parms) ) 

(lispartof (push parml ( institution- ispartof place)) 
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(rest parms) ) 

;; Misc. non-rules 

{:place-var (set parml place) 

(rest parms) ) 
(rinvisible parms) 
))))) 

*'t»ttiittltttttittt7ftiititttittittt 

;; These next three functions are for debugging help only 

(defun gt (key) 

(format t »»~{-%-.S-}'-%*-%-{~%-S-} " 
(gethash key *geo-tokens*) 

(gethash (string -upcase key) ♦geo- tokens*) ) ) 

(defun show-geo () 

(let ( (places nil) ) 

(maphash #' (lambda (string values) 

(push (cons string values) places)) 
*geo- tokens*) 

(delist (string+values (sort places #«string< :key #'first)) 
(format t ««%~A-{-% -S-}" 
(car string+values) 
(cdr string+values))))) 

(defun 1 (address) 

(format t «^{-.%~s~%~} " (locate address))) 
/////#/;///#//;/;;;;;;;;;;;;;;;/;;;;;;;;;;;;;;;;;;;;;;;;; 

;;; ael 000728 created as new file 

®@file serv_mcl 

( in -package : ccl ) 

#1 

Step by step guide to web server programming on the Macintosh with MCL. 

Introduction: Common Lisp is a great tool for building CGI applications. 
A complete web server built in Common Lisp, called CL-HTTP, is available 
for several computing platforms, but it is a big, cotiqplicated package 
that, by all accounts, takes awhile to learn. 

As a Macintosh user, I wanted a simpler, less imposing way to build CGI 
applications in Macintosh Common Lisp. SERVERGLUE . LISP does that. This 
small bit of code, combined with the freeware webservers available for 
the Mac, provides the missing piece needed to start building CGI 
applications in Lisp. It is derived from code originally developed by 
Michael Travers of the MIT Media Lab. 

If you are new to web CGI authoring, you will want to skip over the code for 
now, and read the instructions. 

i# 



; ; ; ; It should respond to event by calling one of two functions: 
;;;; cl -user :: handle -cgi -post or cl -user :: handle -cgi -get 

(require rappleevent -toolkit) 



Page 69 of 82 



(install-appleevent-handler : |WWWJ^[ : | sdoc | ' handle -cgi -event) 

(defconstant *crlf* (format nil "~c-C" #\Linefeed #\Newline) ) 

(def parameter *http-fmt* 

(format nil "HTTP/1.0 200 OK-A- 

MIME- Vers ion : 1.0-:* -A- 

Content-type : text/html- : *-A~ : *~A-— A- : *-A" 
*crlf*) ) 

(defparameter *http-fmt* 

(format nil " Content- type : text/html *.A-':**A — A-:*-A" *crlf *) ) 

(defparameter *http-fmt* ; Use this with Microsoft personal 

web server 

(format nil " — A~A" *crlf *) ) 

(defun handle-cgi- event (application theAppleEvent reply handlerRef con) 
(declare (ignore application handlerRef con) ) 

(let {(method (ae-get -parameter- char theAppleEvent : |meth| t) ) ) 
(ae-put -parameter-char 
reply 

#$keyDirectOb j ect 
(format nil *http-fmt* 

(cl-user: :handle-cgi (ae- get -parameter- char 

theAppleEvent 

(if (string= method "POST") :|post| 
:|kfor|) * 

t)))))) 

#1 

(defun handle-cgi -event (application theAppleEvent reply handlerRef con) 
"Returns all information accessible to CGI script." 
(declare (ignore application handlerRef con) ) 
( ae -put -parameter- char 
reply 

#$keyDirectOb j ect 
(format nil *http-fmt* 

(form^at nil "<html><body>< table 
horde r> ~ { -A- }</table>< /body > < /html > " 

(mapcar #« (lambda (field) 

(format nil "<tr><td>-S</td><td>-S</td></tr>" 
field 

(ae-get-parameter-char theAppleEvent 

field t))) 

•(:|kfor| :|user| :|pass| :|frmu| : |addr| :|post| 

: |meth| 

:|svnm| : | svpt ( :|scnm| :|ctyp| :|refr| :|Agnt| 

)))))) 
i# 

;;;; End of Macintosh- specif ic source code. 
; ; End 

@@file states 

(mapc # 'make -a- state 



Page 70 of 82 



'( ;; from http://new.usps.com/cgi- 

bin/uspsbv/scripts/content. jsp?A=B&:D=10090&K=B&U=X&Ul=B&U2=H#states 
(al us "Alabama" :dxl) 

(ak us "Alaska" :dxl) 

(az us "Arizona" :dxl :dx-adj "Ariz.") 

(ar us "Arkansas" :dxl) 

(ca us "California" :dxl :dx-adj "Calif.") 

(co us "Colorado" :dxl) 

(ct us "Connecticut" :dxl) 

(de us "Delaware" rdxl) 

(dc us "District of Columbia" :dx2) 

(fl us "Florida" :dxl) 

(ga us "Georgia" :sus "Georgia" :dx-helpx "Georgia" -AND- co us) 

(hi us "Hawaii" :dxl) 

(id us "Idaho" rdxl) 

(il us "Illinois" :dxl) 

(in us "Indiana" :dxl) 

(ia us "Iowa" rdxl) 

(ks us "Kansas" rdxl) 

(ky us "Kentucky" rdxl) 

(la us "Lousiana" rdxl) 

(me us "Maine" rdxl) 

(md us "Maryland" rdxl) 

(ma us "Massachusetts" rdxl) 

(mi us "Michigan" rdxl) 

(mn us "Minnesota" rdxl) 

(ms us "Mississippi" rdxl) 

(mo us "Missouri" rdxl) 

(mt us "Montana" rdxl) 

(ne us "Nebraska" rdxl) 

(nv us "Nevada" rdxl) 

(nh us "New Hampshire" rdx2) 

(nj us "New Jersey" rdx2) 

(nm us "New Mexico" rdx2) 

(ny us "New York" :sus-adj "New York" rdx-adj "New York, USA" rdx-adj 
"NY, USA") 

(nc us "North Carolina" :dx2) 
(nd us "North Dakota" :dx2) 
(oh us "Ohio" rdxl) 
(ok us "Oklahoma" rdxl) 
(or us "Oregon" rdxl) 
(pa us "Pennsylvania" rdxl) 
(pr us "Puerto Rico" :dx2) 
(ri us "Rhode Island" :dx2) 
(sc us "South Carolina" rdx2) 
(sd us "South Dakota" :dx2) 
(tn us "Tennessee" rdxl) 
(tx us "Texas" rdxl) 
(ut us "Utah" rdxl) 
(vt us "Vermont" rdxl) 

(va us "Virginia" rsus-helpx "Virginia" -NOT- 2 (st wv in "Virginia Mason 
Medical Center")) 

(wa us "Washington" :sus "Washington") 
(wv us "West Virginia" rdx2) 
(wi us "Wisconsin" rdxl) 
(V7y us "Wyoming" rdxl) 
/ / 

; ; f romr http r //www, canadapost . ca/CPC2/addrm/pclookup/pccivic . shtml 
;; ENGLISH ONLY! 

(ab ca "Alberta" rdxl) 
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(be ca "British Columbia" :dx2) 
(mb ca "Manitoba" :dxl) 
(nb ca "New Brunswick" :dx2) 
(nf ca "Newfoundland" :dxl) 
(ns ca "Nova Scotia" :dx2) 

(nt ca "Northwest Territories and Nunavut" :dx2 :dx "Nunavut") ;; 
TERRITORIES 

(on ca "Ontario" :sus "Ontario" :dx-helpx "Ontario" -AND- co ca) ; 
Ontario, CA 

(pe ca "Prince Edward Island" :dx2) 

(qc ca "Quebec" :dxl) 

(sk ca "Saskatchewan" :dxl) 

(yt ca "Yukon" :dxl) 

)) 



(boot: : load- logical -path- file "source :city_inst") 

®@file tokenize 

(in-package "TOKENIZER") 

(defparameter *accum- alpha -cap 0) 
(defparameter *accum-alpha-low 1) 
(defparameter *accum-digit 2) 
(defparameter *whitespace 3) 
(defparameter *commalike 4) 
(defparameter *periodlike 5) 
(defparameter *at-sign 6) 
(defparameter *ampersand 7) 
(defparameter *paren-start 8) 
(defparameter *paren-stop 9) 

(defparameter *email-xchar 10) _ 
(defparameter *unknown-char 11) ;all else 



alpha digit # 
space / 
comma 



([{ 
)]} 



(defparameter *char-class -equal-test* #'=) 

(defparameter *charclasses* (make-array 256 : initial -element *unknown-char) ) 

(defun initialize-charclasses (classlist) 
(when, classlist 

(let ((chars (first classlist)) 
(code (second classlist) ) ) 
(dotimes (i (length chars)) 

(setf (aref *charclasses* (char-code (aref chars i) ) ) code)) 
(initialize-charclasses (cddr classlist))))) 

(initialize-charclasses 
(list "ABCDEFGHIJKIjMNOPQRSTXm^XYZ" *accum- alpha -cap 
"abcdefghijlkmnopqrstuvwxyz" *accum-alpha-low 
"0123456789" *accum-digit 
" /" *whitespace 
" , " * commalike 
" . " *periodlike 

* ampersand 
"_" *email-xchar 
«@n *at-sign 
" ({ [" *paren- start 
") }3 " *paren-stop) ) 

(defmacro charcase (selection-key &rest clauses) 
(let ( (var (gensym) ) ) 
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(labels ( (emit-clause (clause) 

(list (list var (first clause)) (second clause)))) 
" (let { ( , var , selection-key) ) 
(cond 

,@(mapcar #' emit-clause clauses) 

(t (error "Unknown character class -S encountered in 
CHARCASE macro. " ,var) )))))) 

(defun dbp (&rest args) 

(format t "-%;;;-{ -S-}" args)) 

(defun char -class (c) 

(aref *charclasses* (char-code c) ) ) 



; ; ; Token inf 
{ de f par ame t er 
(def parameter 
(def parameter 
( de f par ame t e r 
( de f pa r ame t e r 
( de f par ame t er 
(def parameter 
(def parameter 



*default-tokeninf * 0) 

*ti-starts-with-digit* (logior 1 *default- 

*ti -maybe -email* (logior 2 ^default- 

*ti -embedded-period* (logior 4 *default- 

*ti-ends-with-period* (logior 8 *default- 

*ti -has -comma* (logior 16 *default- 

*ti-capitalized (logior 32 *default- 

*ti-end (logior 64 *default- 



tokeninf *) ) 
tokeninf *) ) 
tokeninf *) ) 
tokeninf*) ) 
tokeninf*) ) 
tokeninf*) ) 
tokeninf*) ) 



(def parameter *ti- interest -ampersand* 
( de f parameter * t i - int ere s t -parens tart * 
(def parameter *ti-interest-parenstop* 
(def parameter *ti- interest -underscore* 
(def parameter *ti -interest -misc-char* 



(logior 256 
(logior 512 
(logior 1024 
(logior 2048 
(logior 4096 



*default- 
*default- 
*default- 
*default- 
*default- 



tokeninf*) ) 
tokeninf*) ) 
tokeninf*) ) 
tokeninf*) ) 
tokeninf*) ) 



(defun tz (str) 

(multiple-value-bind (strs infs) 
(tokenize str) 
(dotimes (i (length strs)) 

(format t -S * -A" (aref infs i) 



(aref strs i) ) ) ) ) 



(defun tokenize (str) 

(let (den (length str)) 

(last-i (1- (length str))) 
curchar) 

(multiple-value-bind (tokenstrs tokeninfs curtoken) 
(get - token -ar rays -from-pool len) 
(flet ((add-token (tokenstring) 

(vector -push-extend tokenstring tokenstrs) 
(vector-push-extend *default -tokeninf * tokeninfs) 

for next token 



prepare 



' string) ) ) ) 



(setf (fill -pointer curtoken) 0)) 
(set- forthcoming - tokens - inf ( inf -value ) 
(unless {= inf -value *default- tokeninf*) 

(setf (aref tokeninfs (fill -pointer tokenstrs)) 

(logior (aref tokeninfs (fill-pointer tokenstrs)) 
inf -value) ) ) ) ) 
(macrolet ( (end- current -token () 

" (when (plusp (length curtoken) ) 

(add-token (coerce (COPY-SEQ curtoken) 

(accumulate - curchar ( ) 

" (vector-push-extend curchar curtoken) ) 
(accumulate -curchar-with- inf (inf -value) 
^ (progn 

(set-f orthcoming-tokens-inf , inf -value) 
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first token 



capitalized) 



char - in - t oken -p ) 
starts -with-digit* 
tokeninf*) ) ) 



(vector-push-extend curchar curtoken) ) ) 
( f i r s t - char - in - token -p ( ) 

" (zerop (length curtoken) ) ) ) 
(vector-push-extend *default -tokeninf* tokeninfs) ; prepare for 

(do ((i 0 (incf i) ) ) 
((= i len)) 

(charcase (char-class (setq curchar (aref str i) ) ) 
{*accum-alpha-cap (if (first-char-in- token-p) 

(accumulate-curch^r-with-inf *ti- 

(accumulate -curchar) ) ) 
(*accum-alpha-low (accumulate -curchar) ) 

(*accum-digit (accumulate- curchar -with-inf (if (f irst- 



{*whitespace 
(*commalike 



comma* ) 



(*periodlike 



with-period*) 
embedded-period*) ) ) 
email*) ) 



(*at-sign 
(*ampersand 



last-i) ) 



interest-ampersand*) ) ) 

(*paren-start 

int er e s t -parens tart * ) 

interest-parenstart*) ) ) 

(*paren-stop 

interest-parenstop*) 



*ti- 

*default- 

(end-current- token) ) 
(progn 

( end - current - token ) 

(accumulate -curchar- with-inf *ti-has- 

(end-current -token) ) ) 

(if (next-char-ends-token-p str i last-i) 
(accumulate -curchar-with-inf *ti-ends- 

(accumulate-curchar-with-inf *ti- 

(accumulate-curchar-with-inf *ti-raaybe- 

(if (and (f irst-char-in-token-p) 

(next-char-ends-token-p str i 

(add-token "and") 

(accumulate -curchar-with-inf *ti- 

(if (next-char-ends-token-p str i last-i) 
(accumulate-curchar-with-inf *ti- 

(set-forthcoming-tokens-inf *ti- 

(if (next-char-ends-token-p str i last-i) 
(accumulate-curchar-with-inf *ti- 



(set-forthcoming-tokens-inf *ti- 
( accumulate -curchar -with- inf *ti - interest- 
(accumulate-curchar-with-inf *ti -interest- 



interest -parens top*) ) ) 

( * emai 1 -xchar 

underscore*) ) 

( * unknown - char 

misc-char*) ) ) ) 

( end -<:urr ent - token ) 

(set-forthcoming- tokens-inf *ti-end) 

(add-token "*END*") 

(values tokens trs tokeninfs)))))) 

#1 

(defun get - token- arrays -from-pool (max) 

;; Returns buffer arrays guaranteed to handle a line of <max> characters. 
;; This version does not get from pool, obviously. 
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(values (make-array 30 : adjustable t : fill-pointer 0 : element -type 'string) 

(make-array 30 :adjustable t : fill-pointer 0 : element-type 

• integer) 

(make-array 25 :adjustable t :f ill-pointer 0 :element-type 
' character) ) ) 

i# 

(cl-user: :def resource tokenstr-buf f er : initial-copies 5 

:constructor (make-array 30 :adjustable t :f ill-pointer 0 :element-type 

• string) ) 

(cl-user: :def resource tokeninf -buf f er : initial-copies 5 

:constructor (make-array 30 :adjustable t : fill-pointer 0 :element-type 

• integer) ) 

(cl-user : :def resource curtoken-buf f er : initial -copies 5 

: constructor (make-array 25 : adjustable t : fill -pointer 0 : element -type 
' character) ) 

(defun get- token-arrays -from-pool (max) 

; ; Returns buffer arrays guaranteed to handle a line of <max> characters . 
;; This version does not get from pool, obviously, 
(values (allocate- tokenstr-buf fer) 

(allocate- tokeninf -buf fer) 

(allocate -cur token-buffer) ) ) 

(let ((ending-classes (vector *whitespace *coramalike) ) ) 
(defun next -char -ends- token -p (str i last-i) 
(or (= i last-i) 

(find (char-class (aref str i) ) ending-classes 
:test *char-class-equal-test*) ) ) ) 



®®file xserve -macros 
ft* — — — — — — — — — — — — — -_. 



; ; ; CGI MACROS 

(def parameter * approved -functions* nil) 

(defun .approved-function-p (function-symbol) 

(member function- symbol * approved -functions* :test #'eq)) 

(defun log-cgi-fn (fn-symbol) 
(export fn-symbol) 

(pushnew fn-symbol * approved- functions*) 
(values fn-symbol)) 

(export « (thread)) ; so we can use THREAD var in DEFCGIFNs in other packages. 

(defmacro defcgifn (name arglist &body body) 

"To specify object in arglist, comply with iobjname-key literal" 
;; Don*t know why the following expands arglist incorrectly. 
;; "(first (pushnew (defun ,name (thread &key , ©arglist) etc.] 
"(log-cgi-fn (defun .name , (list* 'thread '&key arglist) 
#+mcl (declare (ignore -if -unused thread) ) 
, ©body) ) ) 

(defmacro defcgifn2 (name arglist &body body) 

; ; Would be nice to do remf calls to remove enumerated args from total 
list. 

(assert (eq »&all (nth (- (length arglist) 2) arglist)) nil 
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"Arglist for cgifn2 -S lacks &all: ~S" name arglist) 
(let ((ovar (nth (1- (length arglist) ) arglist)) 
(keylist (butlast arglist 2))) 
" (log-cgi-fn (defun ,name .{append (list » thread 'fcrest ovar »&key) 

keylist 

' (S:allow-other-keys) ) 
#+mcl (declare (ignore- if -unused thread)) 
,@body)))) 

; 7 Example : 

;; (defcgifn prez (president state party) 

(format nil "<html><body>~A -A ~A< /body >< /html >" president state party)) 

(defparameter *htm- functions* nil) 

(def macro defhtmfn (function -name arglist propskey props &body body) 
(assert (eq » thread (first arglist)) nil 

"First argument for a defhtmfn must be 'thread' (defhtmfn -S -S 

...)" 

function-name arglist) 
(assert (eq propskey :props) nil 

"Must specify : props for defhtmfn --S" function -name) 
;; Now look at top level, or one level below, for a WITH-NEW-PAGE macro. 
;; The < listp > test is needed to screen out the LET, PROGN, etc, 
(assert (or (member 'with -new-page body :key #' first) 

(member 'with-new-page (first body) :key #» (lambda (form) 

(and (listp form) 
(first 

form) ) ) ) ) 

nil 

"Expect WITH-NEW-PAGE somewhere in defhtmfn ~S" function -name) 
(pushnew (cons function-name props) *htm- functions* :key #»car :test #'eq) 
" (defun , function-name , arglist 

(session-hx-add thread (list :HTML-GEN (quote , function- name) ,@(rest 
arglist) ) ) 

; ; < locally > needed in case there are declarations in the function 

body 

;; (as happens in < search-results >, for instance), 

(throw : output -html -page (locally /©body)))) 

(defmacro defaccfn (name arglist &body body) 
" (def \in ,name , (list* 'thread 'stream arglist) 

#+mcl (declare ( ignore- if -xrnused thread stream) ) 
, ©body) ) 

i§t — — -~ 



; ; ; THREAD STREAM MACROS 

(defmacro with-thread-output (streamvar thread &body body) 
" (let ( ( , streamvar (thread-accumulator- stream , thread) ) ) 
,@body) ) 

(defmacro formatt (thread fmt$ &rest args) 
(declare (dynamic -extent args) ) 

"(format (thread-accumulator-stream , thread) , f mt$ ,@args) ) 

(defun formatt-fn (thread fmt$ &rest args) 

(format (thread-accumulator- stream thread) fmt$ args) ) 
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(def macro with -thread -output ( (var thread) &body body) 
" (let ( ( , var (thread -accumulator- stream , thread) ) ) 
, ©body) ) 

(def macro terprit (thread) 

" (terpri (thread-accumulator-stream , thread) ) ) 

(defmacro princt (value thread) 

" (princ , value (thread-accumulator- stream , thread))) 

(defmacro with-new-page ( (thred &key 

(title nil) 

(head "") ; remainder of HEAD section 

(body "") ; attributes for BODY tag 

(home-p t) ) 
ficbody bodyx) 
(let ( (streamvar (gensym) ) ) 

" (with-output-to-string ( , streamvar) 

(setf (thread-accumulator-stream , thred) , streamvar) 
(unwind-protect 
(progn 

(with- new-page 1 , thred , title ,head .body , home-p) 
, ©bodyx 

(with-new-page9 , thred) 
, streamvar) 

(setf (thread-accumulator-stream , thred) nil))))} 

(defun with-new-pagel (thread title head-section body- tag -attributes home-p) 
(let ((actual-title (or title "-no title-"))) 
( format t thread 

"<html><head><title>-A</title>-A-%</head>~%<body 
bgcolor= • #f f f f f f • ~A>~ 

<font face= ' sans-serif ' >" 
actual-title 
head- section 
body- tag-attributes) 
(cgi- anchor thread 'MAIN) 

(html -image -tag thread "ct.gif" : align "right" : border "0") 
(princt "</a>" thread) 

; (html -image -tag thread "betz.gif " :align "left") 
(iinless home-p 

; ; put out clickable link to home page 

) 

(formatt thread "-%<center><h2>~A</h2></center>" actual -title) ) ) 

(defun with-new-page9 (thread) 
(declare (ignore wkey) ) 
(let ((sepS "   |   «)) 

(formatt thread "~%<p><hr><center>-%" ) 

(cgi-anchor-with-text thread "Home" 'homeh) 

(princt sep$ thread) 

(cgi-anchor-with-text thread "Search [broken]" 'searchh) 
(princt sep$ thread) 

(cgi-anchor-with-text thread "People" »peopleh) 

(princt sep$ thread) 

(princt "Logout" thread) 

(princt sep$ thread) 

(princt "About us" thread) 

(princt sepS thread) 

(princt "Comments" thread) 
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(princt "</center></font></body></html>" thread) } ) 



#1 

(defmacro with-f oinn-accumulator ((thread fn) &body body) 
(let ( (streamvar (gensym) ) ) 

" (let ( {, streamvar (thread -accumulator- stream , thread) ) ) 

(:®®format , thread , streamvar "~%<form>~%" , f n ) / chopped down 

,@(wwap2 thread streamvar body) 

( : ©©string , thread , streamvar " </f orm> " ) ) ) ) 

i# 



:ile xserve 
(in-package :cl-user) 

(defmacro with -new- thread ( (var session) &body body) 
;; USE ONLY IN THIS FILE I 
(let ((,var (make -a -thread , session))) 
(unwind-protect 
(progn 

, ©body) 
(dispose -thread ,var) ) ) ) 

(defun handle -cgi (argstring) 

(let* ( (keylist (tokenize-cgi-args argstring)) 
(function (getf keylist :fn))) 
(if (and function 

(setg function (read-f rom-string function) ) 
(approved- functi on -p function) ) 
(progn , 

(with-new- thread (thread (or (get -session keylist) ; uses 

:sn argument from keylist 

(make-a-session) ) ) 

(remf keylist : f n) 
(remf keylist : sn) 

(session-hx-add thread (list* : cgi -request function keylist) ) 
(catch : output -html -page 

(apply function thread keylist) ) ) ) 
(format nil '»<html><body><hl>CGI Error: Unapproved function</hl>-'A<hr>~ 
1!his is not an error a user can fix. Contact: [insert 

name here] <hr> 

<h2> Server received: </h2>-A- 
<h2>Which parses as:</h2>- 

<table border>~{<tr><td>~S</td><td>~S</td></tr>-}</table>- 
<p>## End ##</body></html>" 
function argstring keylist) ) ) ) 



(def resource cgi -tokenize -buffer 

: constructor (make -array 400 : fill-pointer t : adjustable t) 
: initial -copies -1) 

(defmacro with-parse-buf ( (var) &body body) 
""(let ({,var (allocate-cgi-tokenize-buf f er) ) ) 
(unwind-protect 
(progn 

(setf (fill-pointer ,var) 0) 
, ©body) 

(deallocate-cgi-tokenize-buf f er ,var) ) ) ) 
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(defun tokenize-cgi-args (argstring) 

"Converts HTTP CGI arg syntax into LISP keywords -and -values list. 
Will fail if the name of a field begins with a space." 
;; Example: fn=voteS:prez=washington&:vp=adams --> 
;; (:fn "vote" :prez "Washington" :vp "adams") 

(with-parse-buf (buf ) 
(vector -push #\ { buf) 
(vector-push #\ : buf) 
(unwind -protect 

(let ({len (length argstring) ) 
c) 

(setq *read-base* 16) 
(do ((i 0)) 

({>= i len)) 
(setq c (aref argstring i) ) 
(incf i 

(case c 
(#\= 

(vector-push-extend #\Space buf) 
(vector-push-extend #\" buf) 
1) 

(#\& 

(vector-push- extend #\" buf) 
(vector-push-extend #\Space buf) 
(vector -push-extend #\: buf) 
1) 

(#\ + 

(vec tor-push- extend #\Space buf) 
1) 

(#\% 

(setq c (code-char (read-f rom-string argstring nil nil 
:start (1+ i) :end (+ i 3)))) 

(when (char= c #\") 

(vector-push-extend #\\ buf) ) 
(vector-push-extend c buf) 
3) 
(t 

(vector-push- extend c buf) 
1))))) 

(setq *read-base* 10)) ; is cleanup form for unwind-protect 

(vector -push-extend #\" buf) 
(vector-push-extend #\) buf) 
(read-f rom-string (coerce buf 'string)))) 



I 



; ; ; Edit this this value as appropriate 



(def parameter *cgi* "l.cgi") 



1 

(defun cgi-anchor (thread function &rest f ield+value-list) 
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"< field+value > elements should be symbols, not strings." 
;; DEPRECATED IN FAVOR OF CGI -ANCHOR -WITH -TEXT 

(declare (dynamic-extent field+value) ) 
{ format t thread 

"<a href='-«A?fn=-S&sn=-S-{&~A=~A~} 

*cgi* 

function 

(thread- session-key thread) 
f ield+value-list) ) 

(defun cgi-anchor2 (thread function fcrest f ield+value-list) 
; ; Outputs to string, not thread stream, 
(declare (dynamic -extent field+value) ) 
(format nil 

"<a href = • -A?f n=~S&sn=-S-{&-A=:~A'-} ' >" 

*cgi* 

function 

(thread-session-key thread) 
f ield+value-list) ) 

#1 

(defparameter *puiw* 

;; Giving clock-time as the name (second) argument to window. open is good. 
;; If every puiw had same name, Netscape4 would not bring a newly opened 
; ; puiw to the front . 

(format nil "<script>f unction puiw(fn, sn, obj ) {- 

var url='~A?fn=* + f n + '&sn=» + sn + '&-S=' + escape (obj ); - 
var d=new Date ( ) 7 ~ 

window. open (url,d.getTime ( ) , ' height=3 00 ,width=3 00, scrollbars ' ,true) 
} </script>" 
* cgi * ! ob j name -key) ) 

i# 

(defun cgi-anchor-puiw (thread objname fn text &key (pre "") (post "")) 
; ; puiw = pop -up information window 

(assert (stringp objname) nil "Expected a string instead of ~S" objname) 
(formatt thread "-A<a href =\" javascript :puiw( ' ~S ~S -A' ) \">~A</a>-A" 
pre fn (thread- session-key thread) objname text post) ) 

(defixn cgi -anchor -with -text (thread text function &rest f ield+value-list) 
"< field+value > elements should be symbols, not strings," 
(declare (dynamic-extent field+value) ) 
(formatt thread 

"<a href='-A?fn=-'S&:sn=-S-{&-A=-A-} •>-A</a>" 

*cgi* 

function 

(thread- session-key thread) 
f ield+value-list 
text) ) 

#1 Example of calling cgi -anchor -with- text to build link around object. 
(defun cgi-anchor-text2 (thread pre text u-obj post &key fn) 
(princt pre thread) 

(cgi -anchor -with -text thread text fn lobjnarae-key u-obj) 
(princt post thread) ) 

i# 

(defun cgi -href -start (thread function) 

"Good style suggests this should probably be deleted someday. " 
(declare (dynamic -extent field+value) ) 
(formatt thread 

« -A? f n= &sn= -S " 
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*cgi* 
function 

(thread-session-key thread) ) ) 

#1 BUGGY! 

(defun cgi-form (thread function- symbol &rest attribute+value-list) 

"< attribute+value > elements should be symbol and string, respectively." 
(declare (dynamic -extent attribute+value) ) 

#. (format * standard -output* "-%;;; Change form method GET to POST someday 
in < cgi-form >") 

;; Compile-time message above reminds us that GET is deprecated in HTML4, 
;; but GET is more useful for debugging. 
( format t thread 

#. (concatenate 'string "~%<form action=*" *cgi* method=GET-{ 

-S=-S-}>") 

attribute+value - lis t ) 
(formatt thread "~%<input type=hidden name= • f n • value= ' -S ' >~%<input 
type«hidden name=*sn' value=~S>--%" 
function- symbol 
(thread- session- key thread) ) 

) 

l# 

(defun cgi-form- start (thread function- symbol &rest attribute+value -list) 
"< attribute+value > elements should be symbol and string, respectively." 
(declare (dynamic -extent attribute+value) ) 

;; Compile-time message above reminds us that GET is deprecated in HTML4, 
;; but GET is more useful for debugging. 
? t 

#. (format * standard -output* "-%;;; Change form method GET to POST someday 
in < cgi-form >") 

(formatt thread "~%<form action='~A' method=GET-{ ~S=-S-}>" *cgi* 
attribute+value -list) 

(cgi- form-hidden thread 'fn (symbol-name function- symbol) *sn (thread- 
session -key thread) ) ) 

(defun cgi -form-hidden (thread &rest attribute+value-list) 

"< attribute+value > elements should be symbol and string, respectively." 
(declare (dynamic -extent attribute+value) ) 

(formatt thread "-{-'%<input type=hidden name='-S' value=-S>-}" 
attribute+value-list) ) 



(defparameter *sessions* nil) 

(defstruct session 
key 
incept 

uuid • ; unique user id 

hx 

t 7 
/ / 

; ; The application can add other slots here. 

t $ 

t i 

curtallykey ; key to current tally object 

) 
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(defstiruct thread 
session 
incept 

ac cumu 1 a tor - s t r e am 
) 



(def method print-object { (x thread) stream) 
(if t 

(format stream "<THREAD -S>" (thread- incept x) ) 
(call-next-method x stream))) 

(def resource vectorstack : constructor (make-array 10 : fill-pointer 0 
: adjustable t) ) 

(defun get-session (keylist) 

"Returns session object or NIL" 
(let ({key (getf keylist :sn))) 
(when key 

(find (read-from-string key) *sessions* :key #» session-key :test 
#•=)))) 

(LET ( (N 0) ) 

(defun make-a- session {) 

(first (push (make-session :key (random 65535) 

:UUID (INCF N) ; SHOULD COME FROM DATABASE 

MACHINE 

: incept (get -universal -time) ) 

*sessions*) ) ) ) 



(defun session-hx-add (thread data) 

(let ( (session (thread- session thread) ) ) 

(push (cons (- (get-universal-time) (session- incept session)) 
data) 

(session-hx session)))) 

(defun make-a- thread (session) 

(let ( (vstack (allocate -vectorstack) ) ) 
(setf (fill-pointer vstack) 0) 
(make-thread : session session 

: incept (get-universal-time) ) ) ) 

(DEFUN DISPOSE-THREAD (THREAD) 

; (DEALLOCATE-VECTORSTACK (THREAD-FINDINGS -TRYING -TO- INFER THREAD)) 
THREM) 



(defun thread- session-key (thread) 

(session-key (thread-session thread) ) ) 
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